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

module Transaq
  (
    CommandConnect(..),
    Language(..),
    TransaqCommand(..),
    TransaqResponseC(..),
    TransaqResponse(..),
    SecurityId(..),
    CommandDisconnect(..),
    CommandSubscribe(..),
    CommandNewOrder(..),
    CommandCancelOrder(..),
    CommandGetSecuritiesInfo(..),
    CommandGetHistoryData(..),
    CommandChangePass(..),
    ResponseResult(..),
    ResponseCandles(..),
    ResponseServerStatus(..),
    ResponseCandleKinds(..),
    ResponseMarkets(..),
    ResponseSecurities(..),
    ResponseSecInfo(..),
    ResponseQuotations(..),
    ResponseAllTrades(..),
    ResponseTrades(..),
    ResponseQuotes(..),
    ResponseOrders(..),
    ResponseClient(..),
    ClientData(..),
    Quotation(..),
    Quote(..),
    TradeNotification(..),
    OrderNotification(..),
    OrderStatus(..),
    AllTradesTrade(..),
    Tick(..),
    ConnectionState(..),
    MarketInfo(..),
    Security(..),
    CandleKind(..),
    ResponseCandlesStatus(..),
    Candle(..),
    UnfilledAction(..),
    TradeDirection(..)
  ) 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           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     :: 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 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 Candle =
  Candle
  {
    cTimestamp    :: UTCTime
  , cOpen         :: Double
  , cHigh         :: Double
  , cLow          :: Double
  , cClose        :: Double
  , cVolume       :: Int
  , cOpenInterest :: Int
  } deriving (Show, Eq, Ord)

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

data ResponseCandles =
  ResponseCandles
  {
    cPeriodId :: Int
  , cStatus   :: ResponseCandlesStatus
  , cSecurity :: SecurityId
  , cCandles  :: [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
      {
        cPeriodId = periodId
      , cStatus = status
      , cSecurity = SecurityId board seccode
      , cCandles = 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 "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
          }

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 ClientData =
  ClientData
  {
    cClientId :: T.Text
  , cType     :: T.Text
  , cCurrency :: T.Text
  , cMarket   :: T.Text
  , cUnion    :: T.Text
  , cForts    :: Maybe T.Text
  } deriving (Show, Eq, Ord)

newtype ResponseClient = ResponseClient ClientData
  deriving (Show, Eq, Ord)

instance TransaqResponseC ResponseClient where
  fromXml root = do
    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 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
  {
    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)

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
          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 {..}
        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 =
    OrderActive
  | OrderCancelled
  | OrderDenied
  | OrderDisabled
  | OrderExpired
  | OrderFailed
  | OrderForwarding
  | OrderInactive
  | OrderMatched
  | OrderRefused
  | OrderRejected
  | OrderRemoved
  | OrderWait
  | OrderWatching
  deriving (Show, Eq, Ord)

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

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
        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
        oClient <- T.pack <$> childContent "client" tag
        oUnion <- T.pack <$> childContent "union" tag
        oStatus <- childContent "status" tag >>= parseStatus
        oBuysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack
        oTimestamp <- childContent "time" tag >>= parseTimestamp . T.pack
        oBrokerRef <- T.pack <$> childContent "brokerref" tag
        oBalance <- childContent "balance" tag >>= readMaybe
        oPrice <- childContent "price" tag >>= readMaybe
        oQuantity <- childContent "quantity" tag >>= readMaybe
        oResult <- T.pack <$> childContent "result" tag
        return . Just $ 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 TradeNotification =
  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)

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
        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 {..}

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
  | 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 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