transaq-connector/src/Transaq.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards       #-}

module Transaq
  (
    CommandConnect(..),
    Language(..),
    TransaqCommand(..),
    TransaqResponseC(..),
    TransaqResponse(..),
    SecurityId(..),
    CommandDisconnect(..),
    CommandSubscribe(..),
    CommandNewOrder(..),
    CommandCancelOrder(..),
    CommandGetSecuritiesInfo(..),
    ResponseResult(..),
    ResponseCandles(..),
    ResponseServerStatus(..),
    ResponseCandleKinds(..),
    ResponseMarkets(..),
    ResponseSecurities(..),
    ResponseSecInfo(..),
    ResponseQuotations(..),
    ResponseAllTrades(..),
    ResponseTrades(..),
    ResponseQuotes(..),
    Quotation(..),
    Quote(..),
    TradeNotification(..),
    OrderNotification(..),
    AllTradesTrade(..),
    Tick(..),
    ConnectionState(..),
    MarketInfo(..)
  ) where

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.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           Debug.Trace
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)

data Language = LanguageRu | LanguageEn
  deriving (Show, Eq, Ord)

instance Node Language where
  node n LanguageRu = node n ("ru" :: String)
  node n LanguageEn = node n ("en" :: String)

type TransaqPrice = DecimalRaw Int

strAttr :: String -> String -> Attr
strAttr key val = Attr { attrKey = blank_name { qName = key}, attrVal = val}

fromBool :: Bool -> String
fromBool True  = "true"
fromBool False = "false"

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


class TransaqCommand t where
  toXml :: t -> T.Text

class TransaqResponseC t where
  fromXml :: Element -> Maybe t

data CommandConnect =
  CommandConnect
  {
    login          :: T.Text,
    password       :: T.Text,
    host           :: T.Text,
    port           :: Int,
    language       :: Language,
    autopos        :: Bool,
    micexRegisters :: Bool,
    milliseconds   :: Bool,
    utcTime        :: Bool,
    proxy          :: (), -- not supported
    rqDelay        :: Maybe Int,
    sessionTimeout :: Maybe Int,
    requestTimeout :: Maybe Int,
    pushULimits    :: Maybe Int,
    pushPosEquity  :: Maybe Int
  } deriving (Show, Eq, Ord)

instance Node CommandConnect where
  node n CommandConnect {..} = node n (attrs, subnodes)
    where
      attrs = [strAttr "id" "connect"]
      subnodes =
        [ unode "login" (T.unpack login)
        , unode "password" (T.unpack password)
        , unode "host" (T.unpack host)
        , unode "port" (show port)
        , unode "language" language
        , unode "autopos" (fromBool autopos)
        , unode "micex_registers" (fromBool micexRegisters)
        , unode "milliseconds" (fromBool milliseconds)
        , unode "utc_time" (fromBool utcTime)
        ]
        ++ maybeToList (unode "rqdelay" . show <$> rqDelay)
        ++ maybeToList (unode "session_timeout" . show <$> sessionTimeout)
        ++ maybeToList (unode "request_timeout" . show <$> requestTimeout)
        ++ maybeToList (unode "push_u_limits" . show <$> pushULimits)
        ++ maybeToList (unode "push_pos_limits" . show <$> pushPosEquity)

instance TransaqCommand CommandConnect where
  toXml = T.pack . showElement . unode "command"

data CommandDisconnect = CommandDisconnect
  deriving (Show, Eq, Ord)

instance TransaqCommand CommandDisconnect where
  toXml CommandDisconnect = T.pack . showElement $ unode "command" [strAttr "id" "disconnect"]

data SecurityId =
  SecurityId
  {
    board   :: T.Text
  , seccode :: T.Text
  } deriving (Show, Eq, Ord)

instance Node SecurityId where
  node n SecurityId {..} = node n
    [ unode "board" (T.unpack board)
    , unode "seccode" (T.unpack seccode)
    ]

data CommandSubscribe =
  CommandSubscribe
  {
    alltrades  :: [SecurityId]
  , quotations :: [SecurityId]
  , quotes     :: [SecurityId]
  } deriving (Show, Eq, Ord)

instance TransaqCommand CommandSubscribe where
  toXml CommandSubscribe {..} =
    T.pack . showElement $ unode "command" ([strAttr "id" "subscribe"],
      [ unode "alltrades" $ fmap (unode "security") alltrades
      , unode "quotations" $ fmap (unode "security") quotations
      , unode "quotes" $ fmap (unode "security") quotes
      ])

data CommandUnsubscribe =
  CommandUnsubscribe
  {
    alltrades  :: [SecurityId]
  , quotations :: [SecurityId]
  , quotes     :: [SecurityId]
  } deriving (Show, Eq, Ord)

instance TransaqCommand CommandUnsubscribe where
  toXml CommandUnsubscribe {..} =
    T.pack . showElement $ unode "command" ([strAttr "id" "unsubscribe"],
      [ unode "alltrades" $ fmap (unode "security") alltrades
      , unode "quotations" $ fmap (unode "security") quotations
      , unode "quotes" $ fmap (unode "security") quotes
      ])

data CommandGetHistoryData =
  CommandGetHistoryData
  {
    security :: SecurityId
  , periodId :: Int
  , count    :: Int
  , reset    :: Bool
  } deriving (Show, Eq, Ord)

instance TransaqCommand CommandGetHistoryData where
  toXml CommandGetHistoryData {..} =
    T.pack . showElement $ unode "command" ([strAttr "id" "gethistorydata"],
      [ unode "security" security
      , unode "period" (show periodId)
      , unode "count" (show count)
      , unode "reset" (fromBool reset)
      ])

data TradeDirection = Buy | Sell
  deriving (Show, Eq, Ord)

instance Node TradeDirection where
  node n Buy  = node n ("B" :: String)
  node n Sell = node n ("S" :: String)

data UnfilledAction =
    UnfilledPutInQueue
  | UnfilledFOK
  | UnfilledIOC
  deriving (Show, Eq, Ord)

instance Node UnfilledAction where
  node n UnfilledPutInQueue = node n ("PutInQueue" :: String)
  node n UnfilledFOK        = node n ("FOK" :: String)
  node n UnfilledIOC        = node n ("IOC" :: String)

data CommandNewOrder =
  CommandNewOrder
  {
    security  :: SecurityId
  , client    :: T.Text
  , unionCode :: T.Text
  , price     :: TransaqPrice
  , quantity  :: Int
  , buysell   :: TradeDirection
  , bymarket  :: Bool
  , brokerRef :: T.Text
  , unfilled  :: UnfilledAction
  , usecredit :: Bool
  , nosplit   :: Bool
  } deriving (Show, Eq, Ord)

instance TransaqCommand CommandNewOrder where
  toXml CommandNewOrder {..} =
    T.pack . showElement $ unode "command" ([strAttr "id" "neworder"],
      [ unode "security" security
      , unode "client" $ T.unpack client
      , unode "union" $ T.unpack unionCode
      , unode "price" $ show price
      , unode "quantity" $ show quantity
      , unode "buysell" buysell
      , unode "brokerref" $ T.unpack brokerRef
      , unode "unfillled" unfilled
      ]
      ++ boolToList "bymarket" bymarket
      ++ boolToList "usecredit" usecredit
      ++ boolToList "nosplit" nosplit)
    where
      boolToList n True  = [unode n ("" :: String)]
      boolToList _ False = []

newtype CommandCancelOrder =
  CommandCancelOrder
  {
    transactionId :: Integer
  } deriving (Show, Eq, Ord)

instance TransaqCommand CommandCancelOrder where
  toXml CommandCancelOrder{..} =
    T.pack . showElement $ unode "command" ([strAttr "id" "cancelOrder"],
      [ unode "transactionid" (show transactionId)])

newtype CommandGetSecuritiesInfo =
  CommandGetSecuritiesInfo
  {
    securities :: [SecurityId]
  } deriving (Show, Eq, Ord)

instance TransaqCommand CommandGetSecuritiesInfo where
  toXml CommandGetSecuritiesInfo{..} =
    T.pack . showElement $ unode "command" ([strAttr "id" "get_securities_info"],
      fmap (unode "security") securities)

data ResponseResult =
    ResponseSuccess
  | ResponseFailure T.Text
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseResult where
  fromXml root =
    if qName (elName root) == "result"
      then
        if findAttr (blank_name {qName = "success"}) root == Just "true"
          then Just ResponseSuccess
          else Just . ResponseFailure . T.pack . concatMap cdData . onlyText . elContent $ root
      else Nothing


data Candle =
  Candle
  {
    cTimestamp    :: UTCTime
  , cOpen         :: TransaqPrice
  , cHigh         :: TransaqPrice
  , cLow          :: TransaqPrice
  , cClose        :: TransaqPrice
  , cVolume       :: Int
  , cOpenInterest :: Int
  } deriving (Show, Eq, Ord)

data ResponseCandlesStatus =
    StatusEndOfHistory
  | StatusDone
  | StatusPending
  | StatusUnavaliable
  deriving (Show, Eq, Ord)

data ResponseCandles =
  ResponseCandles
  {
    periodId :: Int
  , status   :: ResponseCandlesStatus
  , security :: SecurityId
  , candles  :: [Candle]
  } deriving (Show, Eq, Ord)

uname :: String -> QName
uname x = blank_name {qName = x}

childContent :: String -> Element -> Maybe String
childContent tag el = strContent <$> findChild (uname tag) el

instance TransaqResponseC ResponseCandles 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
      {
        periodId = periodId
      , status = status
      , security = SecurityId board seccode
      , candles = candles
      }
    where
      parseStatus :: Int -> Maybe ResponseCandlesStatus
      parseStatus intStatus =
        case intStatus of
          0 -> Just StatusEndOfHistory
          1 -> Just StatusDone
          2 -> Just StatusPending
          3 -> Just StatusUnavaliable
          _ -> Nothing
      parseCandle element = do
        timestamp <- findAttr (uname "open") element >>= parseTimestamp . T.pack
        open <- findAttr (uname "open") element >>= readMaybe
        high <- findAttr (uname "high") element >>= readMaybe
        low <- findAttr (uname "low") element >>= readMaybe
        close <- findAttr (uname "close") element >>= readMaybe
        volume <- findAttr (uname "volume") element >>= readMaybe
        openInterest <- findAttr (uname "oi") element >>= readMaybe
        return Candle
          {
            cTimestamp = timestamp
          , cOpen = open
          , cHigh = high
          , cLow = low
          , cClose = close
          , cVolume = volume
          , cOpenInterest = openInterest
          }

data ConnectionState =
    Connected
  | Disconnected
  | Error T.Text
  deriving (Show, Eq, Ord)

data ResponseServerStatus =
  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
  fromXml root = do
    let serverId = findAttr (uname "id") root >>= readMaybe
    connectedStr <- findAttr (uname "connected") root
    state <- case connectedStr of
      "true"  -> pure Connected
      "false" -> pure Disconnected
      "error" -> pure $ Error (T.pack $ strContent root)
      _       -> pure Disconnected
    let recover =
          case findAttr (uname "recover") root of
            Just "true" -> pure True
            _           -> pure False
    let serverTimezone = T.pack <$> findAttr (uname "server_tz") root
    let systemVersion = findAttr (uname "sys_ver") root >>= readMaybe
    let build = findAttr (uname "build") root >>= readMaybe
    pure $ ResponseServerStatus {..}

data MarketInfo =
  MarketInfo
  { marketId   :: Int
  , marketName :: T.Text
  } deriving (Show, Eq, Ord)

newtype ResponseMarkets = ResponseMarkets [MarketInfo]
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseMarkets where
  fromXml root = do
    markets <- mapM parseMarketInfo $ elChildren root
    pure . ResponseMarkets . catMaybes $ markets
    where
      parseMarketInfo tag =
        if (qName . elName) tag == "market"
        then do
          marketId <- findAttr (uname "id") tag >>= readMaybe
          let marketName = T.pack $ strContent tag
          pure $ Just $ MarketInfo {..}
        else pure Nothing

data CandleKind =
  CandleKind
  {
    kCandleKindId :: Int
  , kPeriod       :: Int
  , kName         :: T.Text
  } deriving (Show, Eq, Ord)

newtype ResponseCandleKinds = ResponseCandleKinds [CandleKind]
  deriving (Show, Eq, Ord)


instance TransaqResponseC ResponseCandleKinds where
  fromXml root = do
    kinds <- mapM parseCandleKind $ elChildren root
    pure . ResponseCandleKinds . catMaybes $ kinds
    where
      parseCandleKind tag =
        if (qName . elName) tag == "kind"
        then do
          kCandleKindId <- childContent "id" tag >>= readMaybe
          kPeriod <- childContent "period" tag >>= readMaybe
          kName <- T.pack <$> childContent "name" tag
          pure . Just $ CandleKind {..}
        else pure Nothing

data Security =
  Security
  {
    secId      :: Int
  , active     :: Bool
  , seccode    :: T.Text
  , instrClass :: T.Text
  , board      :: T.Text
  , market     :: T.Text
  , currency   :: T.Text
  , shortName  :: T.Text
  , decimals   :: Int
  , minStep    :: Double
  , lotSize    :: Int
  , lotDivider :: Int
  , pointCost  :: Double
  , secType    :: T.Text
  } deriving (Show, Eq, Ord)

newtype ResponseSecurities =
  ResponseSecurities [Security]
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseSecurities where
  fromXml root = do
    securities <- mapM parseSecurity $ elChildren root
    pure . ResponseSecurities . catMaybes $ securities
    where
      parseSecurity tag =
        if (qName . elName) tag == "security"
        then do
          secId <- findAttr (uname "secid") tag >>= readMaybe
          active <- findAttr (uname "active") tag >>= parseBool
          seccode <- T.pack <$> childContent "seccode" tag
          instrClass <- T.pack <$> childContent "instrclass" tag
          board <- T.pack <$> childContent "instrclass" tag
          market <- T.pack <$> childContent "market" tag
          currency <- T.pack <$> childContent "currency" tag
          shortName <- T.pack <$> childContent "shortname" tag
          decimals <- childContent "decimals" tag >>= readMaybe
          minStep <- childContent "minstep" tag >>= readMaybe
          lotSize <- childContent "lotsize" tag >>= readMaybe
          lotDivider <- childContent "lotdivider" tag >>= readMaybe
          pointCost <- childContent "point_cost" tag >>= readMaybe
          secType <- T.pack <$> childContent "sectype" tag
          pure . Just $ Security {..}
        else
          pure Nothing

      parseBool "true"  = Just True
      parseBool "false" = Just False
      parseBool _       = Nothing


data ResponseSecInfo =
  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
  fromXml tag = do
    secId <- findAttr (uname "secid") tag >>= readMaybe
    secName <- T.pack <$> childContent "secname" tag
    secCode <- T.pack <$> childContent "seccode" tag
    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
    pointCost <- childContent "point_cost" tag >>= readMaybe
    pure ResponseSecInfo {..}

data Quotation =
  Quotation
  {
    qSecId         :: Int
  , qBoard         :: T.Text
  , qSeccode       :: T.Text
  , qOpen          :: Double
  , qWaprice       :: Double
  , qBidDepth      :: Int
  , qBidDepthT     :: Int
  , qNumBids       :: Int
  , qOfferDepth    :: Int
  , qOfferDepthT   :: Int
  , qBid           :: Double
  , qOffer         :: Double
  , qNumOffers     :: Int
  , qNumTrades     :: Int
  , qVolToday      :: Int
  , qOpenPositions :: Int
  , qLastPrice     :: Double
  , qQuantity      :: Int
  , qTimestamp     :: UTCTime
  , qValToday      :: Double
  } deriving (Show, Eq, Ord)

newtype ResponseQuotations =
  ResponseQuotations [Quotation]
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseQuotations where
  fromXml root = do
    quotations <- mapM parseQuotation $ elChildren root
    pure . ResponseQuotations . catMaybes $ quotations
    where
      parseQuotation tag = do
        qSecId <- findAttr (uname "secid") tag >>= readMaybe
        qBoard <- T.pack <$> childContent "board" tag
        qSeccode <- T.pack <$> childContent "seccode" tag
        qOpen <- childContent "open" tag >>= readMaybe
        qWaprice <- childContent "waprice" tag >>= readMaybe
        qBidDepth <- childContent "biddepth" tag >>= readMaybe
        qBidDepthT <- childContent "biddeptht" tag >>= readMaybe
        qNumBids <- childContent "numbids" tag >>= readMaybe
        qBid <- childContent "bid" tag >>= readMaybe
        qOfferDepth <- childContent "offerdepth" tag >>= readMaybe
        qOfferDepthT <- childContent "offerdeptht" tag >>= readMaybe
        qNumOffers <- childContent "numoffers" tag >>= readMaybe
        qOffer <- childContent "offer" tag >>= readMaybe
        qNumTrades <- childContent "numtrades" tag >>= readMaybe
        qVolToday <- childContent "voltoday" tag >>= readMaybe
        qOpenPositions <- childContent "openpositions" tag >>= readMaybe
        qLastPrice <- childContent "last" tag >>= readMaybe
        qQuantity <- childContent "quantity" tag >>= readMaybe
        qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack)
        qValToday <- childContent "valToday" tag >>= readMaybe
        pure $ Just Quotation {..}

data TradingPeriod =
    PeriodOpen
  | PeriodNormal
  | PeriodClose
  | PeriodUnknown
  deriving (Show, Eq, Ord)

data AllTradesTrade =
  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)

newtype ResponseAllTrades =
  ResponseAllTrades [AllTradesTrade]
  deriving (Show, Eq, Ord)

parseTradeDirection :: T.Text -> Maybe TradeDirection
parseTradeDirection t =
  case t of
    "B" -> Just Buy
    "S" -> Just Sell
    _   -> Nothing

instance TransaqResponseC ResponseAllTrades where
  fromXml root = do
    alltrades <- mapM parseAllTrade $ elChildren root
    pure . ResponseAllTrades . catMaybes $ alltrades
    where
      parseAllTrade tag = do
        attSecId <- findAttr (uname "secid") tag >>= readMaybe
        attSecCode <- T.pack <$> childContent "seccode" tag
        attTradeNo <- childContent "tradeno" tag >>= readMaybe
        attTimestamp <- T.pack <$> childContent "time" tag >>= parseTimestamp
        attBoard <- T.pack <$> childContent "board" tag
        attPrice <- childContent "price" tag >>= readMaybe
        attQuantity <- childContent "quantity" tag >>= readMaybe
        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 {..}

      parseTradingPeriod :: String -> Maybe TradingPeriod
      parseTradingPeriod "O" = Just PeriodOpen
      parseTradingPeriod "N" = Just PeriodNormal
      parseTradingPeriod "C" = Just PeriodClose
      parseTradingPeriod _   = Nothing


data Quote =
  Quote
  {
    secId   :: Int
  , board   :: T.Text
  , secCode :: T.Text
  , price   :: Double
  , source  :: T.Text
  , yield   :: Int
  , buy     :: Int
  , sell    :: Int
  } deriving (Show, Eq, Ord)

newtype ResponseQuotes =
  ResponseQuotes [Quote]
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseQuotes where
  fromXml root = do
    quotes <- mapM parseQuote $ elChildren root
    pure . ResponseQuotes . catMaybes $ quotes
    where
      parseQuote tag = do
        secId <- findAttr (uname "secid") tag >>= readMaybe
        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
        return . Just $ Quote {..}

data OrderStatus =
    OrderCancelled
  | OrderDenied
  | OrderDisabled
  | OrderExpired
  | OrderFailed
  | OrderLinkWait
  | OrderRejected
  | OrderSLExecuted
  | OrderSLForwarding
  | OrderSLGuardTime
  | OrderTPCorrection
  | OrderTPCorrectionGuardTime
  | OrderTPExecuted
  | OrderTPForwarding
  | OrderTPGuardTime
  | OrderWatching
  deriving (Show, Eq, Ord)

data OrderNotification =
  OrderNotification
  {
    transactionId :: Int
  , orderNo       :: Int64
  , secId         :: Int
  , board         :: T.Text
  , secCode       :: T.Text
  , client        :: T.Text
  , union         :: T.Text
  , status        :: OrderStatus
  , buysell       :: TradeDirection
  , timestamp     :: UTCTime
  , brokerRef     :: T.Text
  , balance       :: Int
  , price         :: Double
  , quantity      :: Int
  , result        :: T.Text
  } deriving (Show, Eq, Ord)

newtype ResponseOrders =
  ResponseOrders [OrderNotification]
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseOrders where
  fromXml root = do
    quotes <- mapM parseOrder $ elChildren root
    pure . ResponseOrders . catMaybes $ quotes
    where
      parseOrder tag = do
        transactionId <- findAttr (uname "transactionid") tag >>= readMaybe
        orderNo <- childContent "orderno" tag >>= readMaybe
        secId <- childContent "secid" tag >>= readMaybe
        board <- T.pack <$> childContent "board" tag
        secCode <- T.pack <$> childContent "seccode" tag
        client <- T.pack <$> childContent "client" tag
        union <- T.pack <$> childContent "union" tag
        status <- childContent "status" tag >>= parseStatus
        buysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack
        timestamp <- childContent "time" tag >>= parseTimestamp . T.pack
        brokerRef <- T.pack <$> childContent "brokerref" tag
        balance <- childContent "balance" tag >>= readMaybe
        price <- childContent "price" tag >>= readMaybe
        quantity <- childContent "quantity" tag >>= readMaybe
        result <- T.pack <$> childContent "result" tag
        return . Just $ OrderNotification {..}
      parseStatus "cancelled"               = Just OrderCancelled
      parseStatus "denied"                  = Just OrderDenied
      parseStatus "disabled"                = Just OrderDisabled
      parseStatus "expired"                 = Just OrderExpired
      parseStatus "failed"                  = Just OrderFailed
      parseStatus "linkwait"                = Just OrderLinkWait
      parseStatus "rejected"                = Just OrderRejected
      parseStatus "sl_executed"             = Just OrderSLExecuted
      parseStatus "sl_forwarding"           = Just OrderSLForwarding
      parseStatus "sl_guardtime"            = Just OrderSLGuardTime
      parseStatus "tp_correction"           = Just OrderTPCorrection
      parseStatus "tp_correction_guardtime" = Just OrderTPCorrectionGuardTime
      parseStatus "tp_executed"             = Just OrderTPExecuted
      parseStatus "tp_forwarding"           = Just OrderTPForwarding
      parseStatus "tp_guardtime"            = Just OrderTPGuardTime
      parseStatus "watching"                = Just OrderWatching
      parseStatus _                         = Nothing

data TradeNotification =
  TradeNotification
  {
    secId     :: Int
  , tradeNo   :: Int64
  , orderNo   :: Int64
  , board     :: T.Text
  , secCode   :: T.Text
  , client    :: T.Text
  , union     :: T.Text
  , buysell   :: TradeDirection
  , timestamp :: UTCTime
  , value     :: Double
  , comission :: Double
  , price     :: Double
  } deriving (Show, Eq, Ord)

newtype ResponseTrades =
  ResponseTrades [TradeNotification]
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseTrades where
  fromXml root = do
    quotes <- mapM parseTrade $ elChildren root
    pure . ResponseTrades . catMaybes $ quotes
    where
      parseTrade tag = do
        secId <- childContent "secid" tag >>= readMaybe
        tradeNo <- childContent "tradeno" tag >>= readMaybe
        orderNo <- childContent "orderno" tag >>= readMaybe
        board <- T.pack <$> childContent "board" tag
        secCode <- T.pack <$> childContent "seccode" tag
        client <- T.pack <$> childContent "client" tag
        union <- T.pack <$> childContent "union" tag
        buysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack
        timestamp <- childContent "time" tag >>= parseTimestamp . T.pack
        value <- childContent "value" tag >>= readMaybe
        comission <- childContent "comission" tag >>= readMaybe
        price <- childContent "price" tag >>= readMaybe
        pure . Just $ TradeNotification {..}

data Tick =
  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)

newtype ResponseTicks =
  ResponseTicks [Tick]
  deriving (Show, Eq, Ord)

data TransaqResponse =
    TransaqResponseResult ResponseResult
  | TransaqResponseCandles ResponseCandles
  | TransaqResponseServerStatus ResponseServerStatus
  | TransaqResponseMarkets ResponseMarkets
  | TransaqResponseCandleKinds ResponseCandleKinds
  | TransaqResponseSecurities ResponseSecurities
  | TransaqResponseSecInfo ResponseSecInfo
  | TransaqResponseQuotations ResponseQuotations
  | TransaqResponseAllTrades ResponseAllTrades
  | TransaqResponseQuotes ResponseQuotes
  | TransaqResponseOrders ResponseOrders
  | TransaqResponseTrades ResponseTrades
  deriving (Show, Eq, Ord)

instance TransaqResponseC TransaqResponse where
  fromXml root = case qName . elName $ root of
    "result"        -> TransaqResponseResult <$> fromXml root
    "error"         -> TransaqResponseResult <$> fromXml root
    "candles"       -> TransaqResponseCandles <$> fromXml root
    "server_status" -> TransaqResponseServerStatus <$> fromXml root
    "markets"       -> TransaqResponseMarkets <$> fromXml root
    "candlekinds"   -> TransaqResponseCandleKinds <$> fromXml root
    "securities"    -> TransaqResponseSecurities <$> fromXml root
    "sec_info"      -> TransaqResponseSecInfo <$> fromXml root
    "quotations"    -> TransaqResponseQuotations <$> fromXml root
    "alltrades"     -> TransaqResponseAllTrades <$> fromXml root
    "quotes"        -> TransaqResponseQuotes <$> fromXml root
    "orders"        -> TransaqResponseOrders <$> fromXml root
    "trades"        -> TransaqResponseTrades <$> fromXml root
    _               -> Nothing