transaq-connector/src/Transaq.hs

{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}


module Transaq
  (
    CommandConnect(..),
    Language(..),
    TransaqCommand(..),
    TransaqResponseC(..),
    TransaqResponse(..),
    SecurityId(..),
    CommandDisconnect(..),
    CommandServerStatus(..),
    CommandSubscribe(..),
    CommandNewOrder(..),
    CommandCancelOrder(..),
    CommandGetSecuritiesInfo(..),
    CommandGetHistoryData(..),
    CommandChangePass(..),
    ResponseResult(..),
    ResponseCandles,
    ResponseCandlesB(..),
    ResponseServerStatus,
    ResponseServerStatusB(..),
    ResponseCandleKinds(..),
    ResponseMarkets(..),
    ResponseSecurities(..),
    ResponseSecInfo,
    ResponseSecInfoB(..),
    ResponseQuotations(..),
    ResponseAllTrades(..),
    ResponseTrades(..),
    ResponseQuotes(..),
    ResponseOrders(..),
    ResponseClient(..),
    ClientData,
    ClientDataB(..),
    Quotation,
    QuotationB(..),
    Quote,
    QuoteB(..),
    TradeNotification,
    TradeNotificationB(..),
    OrderNotification,
    OrderNotificationB(..),
    OrderStatus(..),
    AllTradesTrade,
    AllTradesTradeB(..),
    Tick,
    TickB(..),
    ConnectionState(..),
    MarketInfo,
    MarketInfoB(..),
    Security,
    SecurityB(..),
    CandleKind,
    CandleKindB(..),
    ResponseCandlesStatus(..),
    Candle,
    CandleB(..),
    UnfilledAction(..),
    TradeDirection(..),
    TradingPeriod(..)
  ) where

import           Barbies
import           Barbies.Bare
import           Control.Applicative   ((<|>))
import           Control.Error.Util    (hush)
import           Control.Monad         (void)
import           Data.Attoparsec.Text  (Parser, char, decimal, many', 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 (..),
                                        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 ctx t where
  fromXml :: ctx -> 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)

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

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


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     :: !Double
  , 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 CommandChangePass =
  CommandChangePass
  {
    cOldPass :: !T.Text
  , cNewPass :: !T.Text
  } deriving (Show, Eq)

instance TransaqCommand CommandChangePass where
  toXml CommandChangePass{..} =
    T.pack . showElement $ unode "command"
      [strAttr "id" "change_pass",
       strAttr "oldpass" $ T.unpack cOldPass,
       strAttr "newpass" $ T.unpack cNewPass]

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

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


data CandleB t f =
  Candle
  {
    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
  | StatusDone
  | StatusPending
  | StatusUnavaliable
  deriving (Show, Eq, Ord)

data ResponseCandlesB t f =
  ResponseCandles
  {
    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}

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

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
      {
        cPeriodId = periodId
      , cStatus = status
      , cSecurity = SecurityId board seccode
      , cCandles = candles
      } :: ResponseCandlesB Bare f)
    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 "date") 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
        let !openInterest = fromMaybe 0 $ findAttr (uname "oi") element >>= readMaybe
        return (Candle
          {
            cTimestamp = timestamp
          , cOpen = open
          , cHigh = high
          , cLow = low
          , cClose = close
          , cVolume = volume
          , cOpenInterest = openInterest
          } :: CandleB Bare f)

instance TransaqResponseC T.Text (ResponseCandlesB Bare f) where
  fromXml _ = undefined

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

data ResponseServerStatusB t f =
  ResponseServerStatus
  {
    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
    !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 MarketInfoB t f =
  MarketInfo
  { 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 Element 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 {..} :: MarketInfo)
        else pure Nothing

data ClientDataB t f =
  ClientData
  {
    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    :: 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 Element ResponseClient where
  fromXml root = if (qName . elName) root == "client"
    then do
      !cClientId <- T.pack <$> findAttr (uname "id") root
      !cType <- T.pack <$> childContent "type" root
      !cCurrency <- T.pack <$> childContent "currency" root
      !cMarket <- T.pack <$> childContent "market" root
      !cUnion <- T.pack <$> childContent "union" root
      let !cForts = T.pack <$> childContent "forts_acc" root
      Just $ ResponseClient $ ClientData {..}
    else Nothing

data CandleKindB t f=
  CandleKind
  {
    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 Element 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 {..} :: CandleKind)
        else pure Nothing

data SecurityB t f =
  Security
  {
    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 Element ResponseSecurities where
  fromXml root = do
    securities <- mapM parseSecurity $ elChildren root
    pure . ResponseSecurities . catMaybes $ securities
    where
      parseSecurity tag =
        if (qName . elName) tag == "security"
        then do
          !sSecId <- findAttr (uname "secid") tag >>= readMaybe
          !sActive <- findAttr (uname "active") tag >>= parseBool
          !sSeccode <- T.pack <$> childContent "seccode" tag
          !sInstrClass <- T.pack <$> childContent "instrclass" tag
          !sBoard <- T.pack <$> childContent "board" tag
          !sMarket <- T.pack <$> childContent "market" tag
          let !sCurrency = fromMaybe "" $ T.pack <$> childContent "currency" tag
          !sShortName <- T.pack <$> childContent "shortname" tag
          !sDecimals <- childContent "decimals" tag >>= readMaybe
          !sMinStep <- childContent "minstep" tag >>= readMaybe
          !sLotSize <- childContent "lotsize" tag >>= readMaybe
          !sLotDivider <- childContent "lotdivider" tag >>= readMaybe
          !sPointCost <- childContent "point_cost" tag >>= readMaybe
          !sSecType <- T.pack <$> childContent "sectype" tag
          pure . Just $ (Security {..} :: Security)
        else
          pure Nothing

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


data ResponseSecInfoB t f =
  ResponseSecInfo
  {
    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
    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 QuotationB t f =
  Quotation
  {
    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     :: Maybe 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 Element 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
        let !qOpen = childContent "open" tag >>= readMaybe
        let !qWaprice = childContent "waprice" tag >>= readMaybe
        let !qBidDepth = childContent "biddepth" tag >>= readMaybe
        let !qBidDepthT = childContent "biddeptht" tag >>= readMaybe
        let !qNumBids = childContent "numbids" tag >>= readMaybe
        let !qBid = childContent "bid" tag >>= readMaybe
        let !qOfferDepth = childContent "offerdepth" tag >>= readMaybe
        let !qOfferDepthT = childContent "offerdeptht" tag >>= readMaybe
        let !qNumOffers = childContent "numoffers" tag >>= readMaybe
        let !qOffer = childContent "offer" tag >>= readMaybe
        let !qNumTrades = childContent "numtrades" tag >>= readMaybe
        let !qVolToday = childContent "voltoday" tag >>= readMaybe
        let !qOpenPositions = childContent "openpositions" tag >>= readMaybe
        let !qLastPrice = childContent "last" tag >>= readMaybe
        let !qQuantity = childContent "quantity" tag >>= readMaybe
        let !qTimestamp = childContent "time" tag >>= (parseTimestamp . T.pack)
        let !qValToday = childContent "valtoday" tag >>= readMaybe
        pure $ Just (Quotation {..} :: Quotation)

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

data AllTradesTradeB t f =
  AllTradesTrade
  {
    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]
  deriving (Show, Eq, Ord)

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

instance TransaqResponseC Element 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 {..} :: AllTradesTrade)

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


data QuoteB t f =
  Quote
  {
    secId   :: Wear t f Int
  , board   :: Wear t f T.Text
  , secCode :: Wear t f T.Text
  , price   :: Wear t f Double
  , source  :: Maybe T.Text
  , yield   :: Maybe Int
  , buy     :: Maybe Int
  , sell    :: Maybe 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 Element 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
        let !source = T.pack <$> childContent "source" tag
        let !yield = childContent "yield" tag >>= readMaybe
        let !buy = childContent "buy" tag >>= readMaybe
        let !sell = childContent "sell" tag >>= readMaybe
        return . Just $ (Quote {..} :: Quote)

data OrderStatus =
    OrderActive
  | OrderCancelled
  | OrderDenied
  | OrderDisabled
  | OrderExpired
  | OrderFailed
  | OrderForwarding
  | OrderInactive
  | OrderMatched
  | OrderRefused
  | OrderRejected
  | OrderRemoved
  | OrderWait
  | OrderWatching
  deriving (Show, Eq, Ord)

data OrderNotificationB t f =
  OrderNotification
  {
    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        :: Maybe T.Text
  , oUnion         :: Maybe T.Text
  , oStatus        :: Maybe OrderStatus
  , oBuysell       :: Maybe TradeDirection
  , oTimestamp     :: Maybe UTCTime
  , oBrokerRef     :: Maybe T.Text
  , oBalance       :: Maybe Int
  , oPrice         :: Maybe Double
  , oQuantity      :: Maybe Int
  , oResult        :: Maybe T.Text
  } deriving (Generic)

type OrderNotification = OrderNotificationB Bare Identity

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 Element ResponseOrders where
  fromXml root = do
    quotes <- mapM parseOrder $ elChildren root
    pure . ResponseOrders . catMaybes $ quotes
    where
      parseOrder tag = do
        !oTransactionId <- findAttr (uname "transactionid") tag >>= readMaybe
        !oOrderNo <- childContent "orderno" tag >>= readMaybe
        !oSecId <- childContent "secid" tag >>= readMaybe
        !oBoard <- T.pack <$> childContent "board" tag
        !oSecCode <- T.pack <$> childContent "seccode" tag
        let !oClient = T.pack <$> childContent "client" tag
        let !oUnion = T.pack <$> childContent "union" tag
        let !oStatus = childContent "status" tag >>= parseStatus
        let !oBuysell = childContent "buysell" tag >>= parseTradeDirection . T.pack
        let !oTimestamp = childContent "time" tag >>= parseTimestamp . T.pack
        let !oBrokerRef = T.pack <$> childContent "brokerref" tag
        let !oBalance = childContent "balance" tag >>= readMaybe
        let !oPrice = childContent "price" tag >>= readMaybe
        let !oQuantity = childContent "quantity" tag >>= readMaybe
        let !oResult = T.pack <$> childContent "result" tag
        return . Just $ (OrderNotification {..} :: OrderNotification)
      parseStatus "active"     = Just OrderActive
      parseStatus "cancelled"  = Just OrderCancelled
      parseStatus "denied"     = Just OrderDenied
      parseStatus "disabled"   = Just OrderDisabled
      parseStatus "expired"    = Just OrderExpired
      parseStatus "failed"     = Just OrderFailed
      parseStatus "forwarding" = Just OrderForwarding
      parseStatus "inactive"   = Just OrderInactive
      parseStatus "matched"    = Just OrderMatched
      parseStatus "refused"    = Just OrderRefused
      parseStatus "rejected"   = Just OrderRejected
      parseStatus "removed"    = Just OrderRemoved
      parseStatus "wait"       = Just OrderWait
      parseStatus "watching"   = Just OrderWatching
      parseStatus _            = Nothing

data TradeNotificationB t f =
  TradeNotification
  {
    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 Element ResponseTrades where
  fromXml root = do
    quotes <- mapM parseTrade $ elChildren root
    pure . ResponseTrades . catMaybes $ quotes
    where
      parseTrade tag = do
        !tSecId <- childContent "secid" tag >>= readMaybe
        !tTradeNo <- childContent "tradeno" tag >>= readMaybe
        !tOrderNo <- childContent "orderno" tag >>= readMaybe
        !tBoard <- T.pack <$> childContent "board" tag
        !tSecCode <- T.pack <$> childContent "seccode" tag
        !tClient <- T.pack <$> childContent "client" tag
        !tUnion <- T.pack <$> childContent "union" tag
        !tBuysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack
        !tTimestamp <- childContent "time" tag >>= parseTimestamp . T.pack
        !tValue <- childContent "value" tag >>= readMaybe
        !tComission <- childContent "comission" tag >>= readMaybe
        !tQuantity <- childContent "quantity" tag >>= readMaybe
        !tPrice <- childContent "price" tag >>= readMaybe
        pure . Just $ (TradeNotification {..} :: TradeNotification)

data TickB t f =
  Tick
  {
    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]
  deriving (Show, Eq, Ord)

data TransaqResponse =
    TransaqResponseResult ResponseResult
  | TransaqResponseCandles ResponseCandles
  | TransaqResponseClient ResponseClient
  | 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 Element TransaqResponse where
  fromXml root = case qName . elName $ root of
    "result"        -> TransaqResponseResult <$> fromXml root
    "error"         -> TransaqResponseResult <$> fromXml root
    "client"        -> TransaqResponseClient <$> 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