diff --git a/src/TXMLConnector/Internal.hs b/src/TXMLConnector/Internal.hs index 1632c5a..8d9da3d 100644 --- a/src/TXMLConnector/Internal.hs +++ b/src/TXMLConnector/Internal.hs @@ -33,6 +33,7 @@ import Control.Concurrent.STM.TBQueue (TBQueue, flushTBQueue, import Control.Monad (forM_, void, when) import Control.Monad.Extra (whileM) import qualified Data.Bimap as BM +import Data.Functor.Identity (Identity (..)) import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Text as T import Debug.EventCounters (emitEvent) @@ -43,8 +44,10 @@ import Text.XML.Light.Types (Content (Elem), Element (elName), QName (qName)) import TickTable (TickTable, insertTick) -import Transaq (AllTradesTrade (..), - Candle (..), ClientData (..), +import Transaq (AllTradesTrade, + AllTradesTradeB (..), Candle, + CandleB (..), ClientData, + ClientDataB (..), CommandCancelOrder (..), CommandChangePass (..), CommandConnect (..), @@ -54,13 +57,15 @@ import Transaq (AllTradesTrade (..), CommandSubscribe (..), ConnectionState (Disconnected), Language (LanguageEn), - MarketInfo (..), - OrderNotification (..), - OrderStatus (..), - Quotation (..), + MarketInfo, MarketInfoB (..), + OrderNotification, + OrderNotificationB (..), + OrderStatus (..), Quotation, + QuotationB (..), ResponseAllTrades (ResponseAllTrades), ResponseCandleKinds (ResponseCandleKinds), - ResponseCandles (..), + ResponseCandles, + ResponseCandlesB (..), ResponseCandlesStatus (StatusPending), ResponseClient (ResponseClient), ResponseMarkets (ResponseMarkets), @@ -69,8 +74,10 @@ import Transaq (AllTradesTrade (..), ResponseResult (..), ResponseSecurities (ResponseSecurities), ResponseTrades (ResponseTrades), - Security (..), SecurityId (..), - TradeNotification (..), + Security, SecurityB (..), + SecurityId (..), + TradeNotification, + TradeNotificationB (..), TransaqCommand (toXml), TransaqResponse (..), TransaqResponse (..), @@ -299,6 +306,10 @@ handleTransaqData transaqData = do pure Nothing _ -> pure Nothing where + + handleTrade :: (MonadIO m, + MonadReader Env m, + HasLog Env Message m) => TradeNotification -> m () handleTrade transaqTrade = do brState <- asks brokerState trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState) @@ -318,6 +329,8 @@ handleTransaqData transaqData = do _ -> log Warning "TXMLConnector.WorkThread" $ "Unable to find order in ordermap: " <> (T.pack . show) transaqTrade Nothing -> log Warning "TXMLConnector.WorkThread" "No callback for trade notification!" + + fromTransaqTrade :: TradeNotification -> Order -> Maybe TickerInfo -> Trade fromTransaqTrade transaqTrade order maybeTickerInfo = let vol = case maybeTickerInfo of Just tickerInfo -> fromIntegral (tQuantity transaqTrade) * tPrice transaqTrade / tiTickSize tickerInfo * tiTickPrice tickerInfo @@ -340,6 +353,9 @@ handleTransaqData transaqData = do fromDirection Transaq.Buy = AT.Buy fromDirection Transaq.Sell = AT.Sell + handleOrder :: (MonadIO m, + MonadReader Env m, + HasLog Env Message m) => OrderNotification -> m () handleOrder orderUpdate = do brState <- asks brokerState trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState) @@ -358,6 +374,7 @@ handleTransaqData transaqData = do _ -> log Warning "TXMLConnector.WorkThread" "Unable to find order for order notification" Nothing -> log Warning "TXMLConnector.WorkThread" "No callback for order notification" + orderStateFromTransaq :: OrderNotification -> OrderState orderStateFromTransaq orderUpdate = case oStatus orderUpdate of OrderActive -> Submitted diff --git a/src/Transaq.hs b/src/Transaq.hs index 5eb809d..041758e 100644 --- a/src/Transaq.hs +++ b/src/Transaq.hs @@ -1,6 +1,12 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} module Transaq ( @@ -19,36 +25,52 @@ module Transaq CommandGetHistoryData(..), CommandChangePass(..), ResponseResult(..), - ResponseCandles(..), - ResponseServerStatus(..), + ResponseCandles, + ResponseCandlesB(..), + ResponseServerStatus, + ResponseServerStatusB(..), ResponseCandleKinds(..), ResponseMarkets(..), ResponseSecurities(..), - ResponseSecInfo(..), + ResponseSecInfo, + ResponseSecInfoB(..), ResponseQuotations(..), ResponseAllTrades(..), ResponseTrades(..), ResponseQuotes(..), ResponseOrders(..), ResponseClient(..), - ClientData(..), - Quotation(..), - Quote(..), - TradeNotification(..), - OrderNotification(..), + ClientData, + ClientDataB(..), + Quotation, + QuotationB(..), + Quote, + QuoteB(..), + TradeNotification, + TradeNotificationB(..), + OrderNotification, + OrderNotificationB(..), OrderStatus(..), - AllTradesTrade(..), - Tick(..), + AllTradesTrade, + AllTradesTradeB(..), + Tick, + TickB(..), ConnectionState(..), - MarketInfo(..), - Security(..), - CandleKind(..), + MarketInfo, + MarketInfoB(..), + Security, + SecurityB(..), + CandleKind, + CandleKindB(..), ResponseCandlesStatus(..), - Candle(..), + Candle, + CandleB(..), UnfilledAction(..), TradeDirection(..) ) where +import Barbies +import Barbies.Bare import Control.Applicative ((<|>)) import Control.Error.Util (hush) import Control.Monad (void) @@ -56,12 +78,14 @@ 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 GHC.Generics import Text.Read (readMaybe) import Text.XML.Light (Attr (..), CData (cdData), Element (elName), Node (..), QName (..), @@ -122,8 +146,8 @@ parseTimestamp = hush . parseOnly parser class TransaqCommand t where toXml :: t -> T.Text -class TransaqResponseC t where - fromXml :: Element -> Maybe t +class TransaqResponseC ctx t where + fromXml :: ctx -> Maybe t data CommandConnect = CommandConnect @@ -339,7 +363,7 @@ data ResponseResult = | ResponseFailure T.Text deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseResult where +instance TransaqResponseC Element ResponseResult where fromXml root = if qName (elName root) == "result" then @@ -349,17 +373,27 @@ instance TransaqResponseC ResponseResult where else Nothing -data Candle = +data CandleB t f = Candle { - cTimestamp :: !UTCTime - , cOpen :: !Double - , cHigh :: !Double - , cLow :: !Double - , cClose :: !Double - , cVolume :: !Int - , cOpenInterest :: !Int - } deriving (Show, Eq, Ord) + cTimestamp :: Wear t f UTCTime + , cOpen :: Wear t f Double + , cHigh :: Wear t f Double + , cLow :: Wear t f Double + , cClose :: Wear t f Double + , cVolume :: Wear t f Int + , cOpenInterest :: Wear t f Int + } deriving (Generic) + +type Candle = CandleB Bare Identity + +deriving instance FunctorB (CandleB Covered) +deriving instance TraversableB (CandleB Covered) +deriving instance ConstraintsB (CandleB Covered) +deriving instance Show Candle +deriving instance Eq Candle +deriving instance Ord Candle +deriving instance BareB CandleB data ResponseCandlesStatus = StatusEndOfHistory @@ -368,14 +402,24 @@ data ResponseCandlesStatus = | StatusUnavaliable deriving (Show, Eq, Ord) -data ResponseCandles = +data ResponseCandlesB t f = ResponseCandles { - cPeriodId :: !Int - , cStatus :: !ResponseCandlesStatus - , cSecurity :: !SecurityId - , cCandles :: ![Candle] - } deriving (Show, Eq, Ord) + cPeriodId :: Wear t f Int + , cStatus :: Wear t f ResponseCandlesStatus + , cSecurity :: Wear t f SecurityId + , cCandles :: Wear t f [Candle] + } deriving (Generic) + +type ResponseCandles = ResponseCandlesB Bare Identity + +deriving instance FunctorB (ResponseCandlesB Covered) +deriving instance TraversableB (ResponseCandlesB Covered) +deriving instance ConstraintsB (ResponseCandlesB Covered) +deriving instance Show ResponseCandles +deriving instance Eq ResponseCandles +deriving instance Ord ResponseCandles +deriving instance BareB ResponseCandlesB uname :: String -> QName uname x = blank_name {qName = x} @@ -383,20 +427,20 @@ uname x = blank_name {qName = x} childContent :: String -> Element -> Maybe String childContent tag el = strContent <$> findChild (uname tag) el -instance TransaqResponseC ResponseCandles where +instance TransaqResponseC Element (ResponseCandlesB Bare f) where fromXml root = do !periodId <- findAttr (uname "period") root >>= readMaybe !status <- findAttr (uname "status") root >>= readMaybe >>= parseStatus !board <- T.pack <$> findAttr (uname "board") root !seccode <- T.pack <$> findAttr (uname "seccode") root let !candles = mapMaybe parseCandle . elChildren $ root - return ResponseCandles + return (ResponseCandles { cPeriodId = periodId , cStatus = status , cSecurity = SecurityId board seccode , cCandles = candles - } + } :: ResponseCandlesB Bare f) where parseStatus :: Int -> Maybe ResponseCandlesStatus parseStatus intStatus = @@ -414,7 +458,7 @@ instance TransaqResponseC ResponseCandles where !close <- findAttr (uname "close") element >>= readMaybe !volume <- findAttr (uname "volume") element >>= readMaybe let !openInterest = fromMaybe 0 $ findAttr (uname "oi") element >>= readMaybe - return Candle + return (Candle { cTimestamp = timestamp , cOpen = open @@ -423,7 +467,7 @@ instance TransaqResponseC ResponseCandles where , cClose = close , cVolume = volume , cOpenInterest = openInterest - } + } :: CandleB Bare f) data ConnectionState = Connected @@ -431,18 +475,28 @@ data ConnectionState = | Error T.Text deriving (Show, Eq, Ord) -data ResponseServerStatus = +data ResponseServerStatusB t f = ResponseServerStatus { - serverId :: !(Maybe Int) - , state :: !ConnectionState - , recover :: !(Maybe Bool) - , serverTimezone :: !(Maybe T.Text) - , systemVersion :: !(Maybe Int) - , build :: !(Maybe Int) - } deriving (Show, Eq, Ord) - -instance TransaqResponseC ResponseServerStatus where + serverId :: Wear t f (Maybe Int) + , state :: Wear t f ConnectionState + , recover :: Wear t f (Maybe Bool) + , serverTimezone :: Wear t f (Maybe T.Text) + , systemVersion :: Wear t f (Maybe Int) + , build :: Wear t f (Maybe Int) + } deriving (Generic) + +type ResponseServerStatus = ResponseServerStatusB Bare Identity + +deriving instance FunctorB (ResponseServerStatusB Covered) +deriving instance TraversableB (ResponseServerStatusB Covered) +deriving instance ConstraintsB (ResponseServerStatusB Covered) +deriving instance Show ResponseServerStatus +deriving instance Eq ResponseServerStatus +deriving instance Ord ResponseServerStatus +deriving instance BareB ResponseServerStatusB + +instance TransaqResponseC Element ResponseServerStatus where fromXml root = do let !serverId = findAttr (uname "id") root >>= readMaybe !connectedStr <- findAttr (uname "connected") root @@ -460,16 +514,26 @@ instance TransaqResponseC ResponseServerStatus where let !build = findAttr (uname "build") root >>= readMaybe pure $ ResponseServerStatus {..} -data MarketInfo = +data MarketInfoB t f = MarketInfo - { marketId :: !Int - , marketName :: !T.Text - } deriving (Show, Eq, Ord) + { marketId :: Wear t f Int + , marketName :: Wear t f T.Text + } deriving (Generic) + +type MarketInfo = MarketInfoB Bare Identity + +deriving instance FunctorB (MarketInfoB Covered) +deriving instance TraversableB (MarketInfoB Covered) +deriving instance ConstraintsB (MarketInfoB Covered) +deriving instance Show MarketInfo +deriving instance Eq MarketInfo +deriving instance Ord MarketInfo +deriving instance BareB MarketInfoB newtype ResponseMarkets = ResponseMarkets [MarketInfo] deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseMarkets where +instance TransaqResponseC Element ResponseMarkets where fromXml root = do !markets <- mapM parseMarketInfo $ elChildren root pure . ResponseMarkets . catMaybes $ markets @@ -479,24 +543,34 @@ instance TransaqResponseC ResponseMarkets where then do !marketId <- findAttr (uname "id") tag >>= readMaybe let !marketName = T.pack $ strContent tag - pure $ Just $ MarketInfo {..} + pure $ Just $ (MarketInfo {..} :: MarketInfo) else pure Nothing -data ClientData = +data ClientDataB t f = ClientData { - cClientId :: !T.Text - , cType :: !T.Text - , cCurrency :: !T.Text - , cMarket :: !T.Text - , cUnion :: !T.Text - , cForts :: !(Maybe T.Text) - } deriving (Show, Eq, Ord) + cClientId :: Wear t f T.Text + , cType :: Wear t f T.Text + , 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) + } deriving (Generic) + +type ClientData = ClientDataB Bare Identity + +deriving instance FunctorB (ClientDataB Covered) +deriving instance TraversableB (ClientDataB Covered) +deriving instance ConstraintsB (ClientDataB Covered) +deriving instance Show ClientData +deriving instance Eq ClientData +deriving instance Ord ClientData +deriving instance BareB ClientDataB newtype ResponseClient = ResponseClient ClientData deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseClient where +instance TransaqResponseC Element ResponseClient where fromXml root = if (qName . elName) root == "client" then do !cClientId <- T.pack <$> findAttr (uname "id") root @@ -508,19 +582,28 @@ instance TransaqResponseC ResponseClient where Just $ ResponseClient $ ClientData {..} else Nothing -data CandleKind = +data CandleKindB t f= CandleKind { - kCandleKindId :: !Int - , kPeriod :: !Int - , kName :: !T.Text - } deriving (Show, Eq, Ord) + kCandleKindId :: Wear t f Int + , kPeriod :: Wear t f Int + , kName :: Wear t f T.Text + } deriving (Generic) + +type CandleKind = CandleKindB Bare Identity + +deriving instance FunctorB (CandleKindB Covered) +deriving instance TraversableB (CandleKindB Covered) +deriving instance ConstraintsB (CandleKindB Covered) +deriving instance Show CandleKind +deriving instance Eq CandleKind +deriving instance Ord CandleKind +deriving instance BareB CandleKindB newtype ResponseCandleKinds = ResponseCandleKinds [CandleKind] deriving (Show, Eq, Ord) - -instance TransaqResponseC ResponseCandleKinds where +instance TransaqResponseC Element ResponseCandleKinds where fromXml root = do !kinds <- mapM parseCandleKind $ elChildren root pure . ResponseCandleKinds . catMaybes $ kinds @@ -531,33 +614,43 @@ instance TransaqResponseC ResponseCandleKinds where !kCandleKindId <- childContent "id" tag >>= readMaybe !kPeriod <- childContent "period" tag >>= readMaybe !kName <- T.pack <$> childContent "name" tag - pure . Just $ CandleKind {..} + pure . Just $ (CandleKind {..} :: CandleKind) else pure Nothing -data Security = +data SecurityB t f = Security { - sSecId :: !Int - , sActive :: !Bool - , sSeccode :: !T.Text - , sInstrClass :: !T.Text - , sBoard :: !T.Text - , sMarket :: !T.Text - , sCurrency :: !T.Text - , sShortName :: !T.Text - , sDecimals :: !Int - , sMinStep :: !Double - , sLotSize :: !Int - , sLotDivider :: !Int - , sPointCost :: !Double - , sSecType :: !T.Text - } deriving (Show, Eq, Ord) + sSecId :: Wear t f Int + , sActive :: Wear t f Bool + , sSeccode :: Wear t f T.Text + , sInstrClass :: Wear t f T.Text + , sBoard :: Wear t f T.Text + , sMarket :: Wear t f T.Text + , sCurrency :: Wear t f T.Text + , sShortName :: Wear t f T.Text + , sDecimals :: Wear t f Int + , sMinStep :: Wear t f Double + , sLotSize :: Wear t f Int + , sLotDivider :: Wear t f Int + , sPointCost :: Wear t f Double + , sSecType :: Wear t f T.Text + } deriving (Generic) + +type Security = SecurityB Bare Identity + +deriving instance FunctorB (SecurityB Covered) +deriving instance TraversableB (SecurityB Covered) +deriving instance ConstraintsB (SecurityB Covered) +deriving instance Show Security +deriving instance Eq Security +deriving instance Ord Security +deriving instance BareB SecurityB newtype ResponseSecurities = ResponseSecurities [Security] deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseSecurities where +instance TransaqResponseC Element ResponseSecurities where fromXml root = do securities <- mapM parseSecurity $ elChildren root pure . ResponseSecurities . catMaybes $ securities @@ -579,7 +672,7 @@ instance TransaqResponseC ResponseSecurities where !sLotDivider <- childContent "lotdivider" tag >>= readMaybe !sPointCost <- childContent "point_cost" tag >>= readMaybe !sSecType <- T.pack <$> childContent "sectype" tag - pure . Just $ Security {..} + pure . Just $ (Security {..} :: Security) else pure Nothing @@ -588,22 +681,31 @@ instance TransaqResponseC ResponseSecurities where parseBool _ = Nothing -data ResponseSecInfo = +data ResponseSecInfoB t f = ResponseSecInfo { - secId :: !Int - , secName :: !T.Text - , secCode :: !T.Text - , market :: !Int - , pname :: !T.Text - , clearingPrice :: !Double - , minprice :: !Double - , maxprice :: !Double - , pointCost :: !Double - } deriving (Show, Eq, Ord) - - -instance TransaqResponseC ResponseSecInfo where + secId :: Wear t f Int + , secName :: Wear t f T.Text + , secCode :: Wear t f T.Text + , 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 + , pointCost :: Wear t f Double + } deriving (Generic) + +type ResponseSecInfo = ResponseSecInfoB Bare Identity + +deriving instance FunctorB (ResponseSecInfoB Covered) +deriving instance TraversableB (ResponseSecInfoB Covered) +deriving instance ConstraintsB (ResponseSecInfoB Covered) +deriving instance Show ResponseSecInfo +deriving instance Eq ResponseSecInfo +deriving instance Ord ResponseSecInfo +deriving instance BareB ResponseSecInfoB + +instance TransaqResponseC Element ResponseSecInfo where fromXml tag = do secId <- findAttr (uname "secid") tag >>= readMaybe secName <- T.pack <$> childContent "secname" tag @@ -616,36 +718,46 @@ instance TransaqResponseC ResponseSecInfo where pointCost <- childContent "point_cost" tag >>= readMaybe pure ResponseSecInfo {..} -data Quotation = +data QuotationB t f = Quotation { - qSecId :: !Int - , qBoard :: !T.Text - , qSeccode :: !T.Text - , qOpen :: !(Maybe Double) - , qWaprice :: !(Maybe Double) - , qBidDepth :: !(Maybe Int) - , qBidDepthT :: !(Maybe Int) - , qNumBids :: !(Maybe Int) - , qOfferDepth :: !(Maybe Int) - , qOfferDepthT :: !(Maybe Int) - , qBid :: !(Maybe Double) - , qOffer :: !(Maybe Double) - , qNumOffers :: !(Maybe Int) - , qNumTrades :: !(Maybe Int) - , qVolToday :: !(Maybe Int) - , qOpenPositions :: !(Maybe Int) - , qLastPrice :: !(Maybe Double) - , qQuantity :: !(Maybe Int) - , qTimestamp :: !UTCTime - , qValToday :: !(Maybe Double) - } deriving (Show, Eq, Ord) + qSecId :: Wear t f Int + , qBoard :: Wear t f T.Text + , qSeccode :: Wear t f T.Text + , qOpen :: Maybe Double + , qWaprice :: Maybe Double + , qBidDepth :: Maybe Int + , qBidDepthT :: Maybe Int + , qNumBids :: Maybe Int + , qOfferDepth :: Maybe Int + , qOfferDepthT :: Maybe Int + , qBid :: Maybe Double + , qOffer :: Maybe Double + , qNumOffers :: Maybe Int + , qNumTrades :: Maybe Int + , qVolToday :: Maybe Int + , qOpenPositions :: Maybe Int + , qLastPrice :: Maybe Double + , qQuantity :: Maybe Int + , qTimestamp :: Wear t f UTCTime + , qValToday :: Maybe Double + } deriving (Generic) + +type Quotation = QuotationB Bare Identity + +deriving instance FunctorB (QuotationB Covered) +deriving instance TraversableB (QuotationB Covered) +deriving instance ConstraintsB (QuotationB Covered) +deriving instance Show Quotation +deriving instance Eq Quotation +deriving instance Ord Quotation +deriving instance BareB QuotationB newtype ResponseQuotations = ResponseQuotations [Quotation] deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseQuotations where +instance TransaqResponseC Element ResponseQuotations where fromXml root = do quotations <- mapM parseQuotation $ elChildren root pure . ResponseQuotations . catMaybes $ quotations @@ -671,7 +783,7 @@ instance TransaqResponseC ResponseQuotations where let !qQuantity = childContent "quantity" tag >>= readMaybe !qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack) let !qValToday = childContent "valToday" tag >>= readMaybe - pure $ Just Quotation {..} + pure $ Just (Quotation {..} :: Quotation) data TradingPeriod = PeriodOpen @@ -680,20 +792,30 @@ data TradingPeriod = | PeriodUnknown deriving (Show, Eq, Ord) -data AllTradesTrade = +data AllTradesTradeB t f = AllTradesTrade { - attSecId :: !Int - , attSecCode :: !T.Text - , attTradeNo :: !Int64 - , attTimestamp :: !UTCTime - , attBoard :: !T.Text - , attPrice :: !Double - , attQuantity :: !Int - , attBuysell :: !TradeDirection - , attOpenInterest :: !Int - , attPeriod :: !TradingPeriod - } deriving (Show, Eq, Ord) + attSecId :: Wear t f Int + , attSecCode :: Wear t f T.Text + , attTradeNo :: Wear t f Int64 + , attTimestamp :: Wear t f UTCTime + , attBoard :: Wear t f T.Text + , attPrice :: Wear t f Double + , attQuantity :: Wear t f Int + , attBuysell :: Wear t f TradeDirection + , attOpenInterest :: Wear t f Int + , attPeriod :: Wear t f TradingPeriod + } deriving (Generic) + +type AllTradesTrade = AllTradesTradeB Bare Identity + +deriving instance FunctorB (AllTradesTradeB Covered) +deriving instance TraversableB (AllTradesTradeB Covered) +deriving instance ConstraintsB (AllTradesTradeB Covered) +deriving instance Show AllTradesTrade +deriving instance Eq AllTradesTrade +deriving instance Ord AllTradesTrade +deriving instance BareB AllTradesTradeB newtype ResponseAllTrades = ResponseAllTrades [AllTradesTrade] @@ -706,7 +828,7 @@ parseTradeDirection t = "S" -> Just Sell _ -> Nothing -instance TransaqResponseC ResponseAllTrades where +instance TransaqResponseC Element ResponseAllTrades where fromXml root = do alltrades <- mapM parseAllTrade $ elChildren root pure . ResponseAllTrades . catMaybes $ alltrades @@ -722,7 +844,7 @@ instance TransaqResponseC ResponseAllTrades where !attBuysell <- T.pack <$> childContent "buysell" tag >>= parseTradeDirection let !attOpenInterest = fromMaybe 0 $ childContent "openinterest" tag >>= readMaybe let !attPeriod = fromMaybe PeriodUnknown $ childContent "period" tag >>= parseTradingPeriod - pure . Just $ AllTradesTrade {..} + pure . Just $ (AllTradesTrade {..} :: AllTradesTrade) parseTradingPeriod :: String -> Maybe TradingPeriod parseTradingPeriod "O" = Just PeriodOpen @@ -731,24 +853,34 @@ instance TransaqResponseC ResponseAllTrades where parseTradingPeriod _ = Nothing -data Quote = +data QuoteB t f = Quote { - secId :: !Int - , board :: !T.Text - , secCode :: !T.Text - , price :: !Double - , source :: T.Text - , yield :: !Int - , buy :: !Int - , sell :: !Int - } deriving (Show, Eq, Ord) + secId :: Wear t f Int + , 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 + } deriving (Generic) + +type Quote = QuoteB Bare Identity + +deriving instance FunctorB (QuoteB Covered) +deriving instance TraversableB (QuoteB Covered) +deriving instance ConstraintsB (QuoteB Covered) +deriving instance Show Quote +deriving instance Eq Quote +deriving instance Ord Quote +deriving instance BareB QuoteB newtype ResponseQuotes = ResponseQuotes [Quote] deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseQuotes where +instance TransaqResponseC Element ResponseQuotes where fromXml root = do quotes <- mapM parseQuote $ elChildren root pure . ResponseQuotes . catMaybes $ quotes @@ -762,7 +894,7 @@ instance TransaqResponseC ResponseQuotes where !yield <- childContent "yield" tag >>= readMaybe !buy <- childContent "buy" tag >>= readMaybe !sell <- childContent "sell" tag >>= readMaybe - return . Just $ Quote {..} + return . Just $ (Quote {..} :: Quote) data OrderStatus = OrderActive @@ -781,31 +913,41 @@ data OrderStatus = | OrderWatching deriving (Show, Eq, Ord) -data OrderNotification = +data OrderNotificationB t f = OrderNotification { - oTransactionId :: !Int - , oOrderNo :: !Int64 - , oSecId :: !Int - , oBoard :: !T.Text - , oSecCode :: !T.Text - , oClient :: !T.Text - , oUnion :: !T.Text - , oStatus :: !OrderStatus - , oBuysell :: !TradeDirection - , oTimestamp :: !UTCTime - , oBrokerRef :: !T.Text - , oBalance :: !Int - , oPrice :: !Double - , oQuantity :: !Int - , oResult :: !T.Text - } deriving (Show, Eq, Ord) + oTransactionId :: Wear t f Int + , oOrderNo :: Wear t f Int64 + , 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 + } deriving (Generic) + +type OrderNotification = OrderNotificationB Bare Identity + +deriving instance FunctorB (OrderNotificationB Covered) +deriving instance TraversableB (OrderNotificationB Covered) +deriving instance ConstraintsB (OrderNotificationB Covered) +deriving instance Show OrderNotification +deriving instance Eq OrderNotification +deriving instance Ord OrderNotification +deriving instance BareB OrderNotificationB newtype ResponseOrders = ResponseOrders [OrderNotification] deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseOrders where +instance TransaqResponseC Element ResponseOrders where fromXml root = do quotes <- mapM parseOrder $ elChildren root pure . ResponseOrders . catMaybes $ quotes @@ -826,7 +968,7 @@ instance TransaqResponseC ResponseOrders where !oPrice <- childContent "price" tag >>= readMaybe !oQuantity <- childContent "quantity" tag >>= readMaybe !oResult <- T.pack <$> childContent "result" tag - return . Just $ OrderNotification {..} + return . Just $ (OrderNotification {..} :: OrderNotification) parseStatus "active" = Just OrderActive parseStatus "cancelled" = Just OrderCancelled parseStatus "denied" = Just OrderDenied @@ -843,29 +985,39 @@ instance TransaqResponseC ResponseOrders where parseStatus "watching" = Just OrderWatching parseStatus _ = Nothing -data TradeNotification = +data TradeNotificationB t f = TradeNotification { - tSecId :: !Int - , tTradeNo :: !Int64 - , tOrderNo :: !Int64 - , tBoard :: !T.Text - , tSecCode :: !T.Text - , tClient :: !T.Text - , tUnion :: !T.Text - , tBuysell :: !TradeDirection - , tTimestamp :: !UTCTime - , tValue :: !Double - , tComission :: !Double - , tQuantity :: !Int - , tPrice :: !Double - } deriving (Show, Eq, Ord) + tSecId :: Wear t f Int + , tTradeNo :: Wear t f Int64 + , tOrderNo :: Wear t f Int64 + , tBoard :: Wear t f T.Text + , tSecCode :: Wear t f T.Text + , tClient :: Wear t f T.Text + , tUnion :: Wear t f T.Text + , tBuysell :: Wear t f TradeDirection + , tTimestamp :: Wear t f UTCTime + , tValue :: Wear t f Double + , tComission :: Wear t f Double + , tQuantity :: Wear t f Int + , tPrice :: Wear t f Double + } deriving (Generic) + +type TradeNotification = TradeNotificationB Bare Identity + +deriving instance FunctorB (TradeNotificationB Covered) +deriving instance TraversableB (TradeNotificationB Covered) +deriving instance ConstraintsB (TradeNotificationB Covered) +deriving instance Show TradeNotification +deriving instance Eq TradeNotification +deriving instance Ord TradeNotification +deriving instance BareB TradeNotificationB newtype ResponseTrades = ResponseTrades [TradeNotification] deriving (Show, Eq, Ord) -instance TransaqResponseC ResponseTrades where +instance TransaqResponseC Element ResponseTrades where fromXml root = do quotes <- mapM parseTrade $ elChildren root pure . ResponseTrades . catMaybes $ quotes @@ -884,22 +1036,32 @@ instance TransaqResponseC ResponseTrades where !tComission <- childContent "comission" tag >>= readMaybe !tQuantity <- childContent "quantity" tag >>= readMaybe !tPrice <- childContent "price" tag >>= readMaybe - pure . Just $ TradeNotification {..} + pure . Just $ (TradeNotification {..} :: TradeNotification) -data Tick = +data TickB t f = Tick { - secId :: !Int - , tradeNo :: !Int64 - , timestamp :: !UTCTime - , price :: !Double - , quantity :: !Int - , period :: !TradingPeriod - , buySell :: !TradeDirection - , openInterest :: !Int - , board :: !T.Text - , secCode :: !T.Text - } deriving (Show, Eq, Ord) + secId :: Wear t f Int + , tradeNo :: Wear t f Int64 + , timestamp :: Wear t f UTCTime + , price :: Wear t f Double + , quantity :: Wear t f Int + , period :: Wear t f TradingPeriod + , buySell :: Wear t f TradeDirection + , openInterest :: Wear t f Int + , board :: Wear t f T.Text + , secCode :: Wear t f T.Text + } deriving (Generic) + +type Tick = TickB Bare Identity + +deriving instance FunctorB (TickB Covered) +deriving instance TraversableB (TickB Covered) +deriving instance ConstraintsB (TickB Covered) +deriving instance Show Tick +deriving instance Eq Tick +deriving instance Ord Tick +deriving instance BareB TickB newtype ResponseTicks = ResponseTicks [Tick] @@ -921,7 +1083,8 @@ data TransaqResponse = | TransaqResponseTrades ResponseTrades deriving (Show, Eq, Ord) -instance TransaqResponseC TransaqResponse where + +instance TransaqResponseC Element TransaqResponse where fromXml root = case qName . elName $ root of "result" -> TransaqResponseResult <$> fromXml root "error" -> TransaqResponseResult <$> fromXml root diff --git a/test/Spec.hs b/test/Spec.hs index ea08f13..6e60c95 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,15 @@ +import Debug.EventCounters (initEventCounters) +import System.Metrics (newStore) import Test.Tasty import qualified Test.FSM import qualified Test.TickTable main :: IO () -main = defaultMain $ testGroup "Tests" [unitTests] +main = do + store <- newStore + initEventCounters store + defaultMain $ testGroup "Tests" [unitTests] unitTests :: TestTree unitTests = testGroup "Unit Tests" diff --git a/test/Test/Transaq.hs b/test/Test/Transaq.hs new file mode 100644 index 0000000..d0673a4 --- /dev/null +++ b/test/Test/Transaq.hs @@ -0,0 +1,12 @@ + +module Test.Transaq +( + unitTests + ) where + +unitTests :: TestTree +unitTests = testGroup "Parsing" + [ + test + ] + diff --git a/transaq-connector.cabal b/transaq-connector.cabal index 6a771c9..4495a4f 100644 --- a/transaq-connector.cabal +++ b/transaq-connector.cabal @@ -63,6 +63,8 @@ executable transaq-connector , ekg-core , slave-thread , th-printf + , barbies + , xeno extra-lib-dirs: lib ghc-options: -Wall -Wcompat @@ -124,6 +126,8 @@ test-suite transaq-connector-test , ekg-statsd , ekg-core , slave-thread + , xeno + , barbies default-extensions: OverloadedStrings , MultiWayIf , MultiParamTypeClasses