diff --git a/src/Config.hs b/src/Config.hs index ce6b834..52633e7 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -24,6 +24,7 @@ data TransaqConnectorConfig = TransaqConnectorConfig { brokerClientCertificateDir :: Maybe FilePath, tisEndpoint :: T.Text, historyProviderEndpoint :: T.Text, + account :: T.Text, transaqLogin :: T.Text, transaqPassword :: T.Text, transaqHost :: T.Text, diff --git a/src/HistoryProviderServer.hs b/src/HistoryProviderServer.hs index b7be431..420a0b7 100644 --- a/src/HistoryProviderServer.hs +++ b/src/HistoryProviderServer.hs @@ -232,7 +232,7 @@ workThread = do let count = truncate diff `div` periodToSeconds (rqPeriod request) log Debug "HistoryProviderServer.WorkThread" $ "Requesting bars: " <> (T.pack . show) count txml <- asks eTxml - response <- liftIO . makeRequest txml $ Request HistoryRequest + response <- liftIO . makeRequest txml $ RequestHistory HistoryRequest { hrTickerId = rqTicker request , hrTimeframe = BarTimeframe . periodToSeconds . rqPeriod $ request diff --git a/src/Main.hs b/src/Main.hs index ac8819d..c60d640 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,6 +3,9 @@ module Main (main) where import ATrade (libatrade_gitrev, libatrade_version) +import ATrade.Broker.Protocol (NotificationSqnum (NotificationSqnum)) +import ATrade.Broker.Server (startBrokerServer, + stopBrokerServer) import ATrade.Logging (Message (..), Severity (Info), logWith) import ATrade.Logging (fmtMessage) @@ -57,8 +60,17 @@ main = do defaultServerSecurityParams) stopQuoteSourceServer $ \_ -> withTickerInfoServer logger ctx (tisEndpoint cfg) $ \tisH -> do txml <- Connector.start logger cfg qssChannel tisH - withHistoryProviderServer ctx (historyProviderEndpoint cfg) txml logger id $ \_ -> do - forever $ threadDelay 1000000 + bracket (startBrokerServer + [Connector.makeBrokerBackend txml (account cfg)] + ctx + (brokerEndpoint cfg) + (brokerNotificationsEndpoint cfg) + (NotificationSqnum 1) + [] + defaultServerSecurityParams + logger) stopBrokerServer $ \_ -> do + withHistoryProviderServer ctx (historyProviderEndpoint cfg) txml logger id $ \_ -> do + forever $ threadDelay 1000000 log Info "main" "Shutting down" diff --git a/src/TXMLConnector.hs b/src/TXMLConnector.hs index 7c89d41..6e2510f 100644 --- a/src/TXMLConnector.hs +++ b/src/TXMLConnector.hs @@ -15,6 +15,7 @@ module TXMLConnector , HistoryResponse(..) , makeRequest , TXMLConnectorHandle + , makeBrokerBackend ) where import ATrade.Logging (Message, Severity (..), log, @@ -36,14 +37,16 @@ import Control.Concurrent.STM (TVar, atomically, modifyTVar', import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueue, readTBQueue, writeTBQueue) import Control.Monad (forever, void, when) +import qualified Data.Bimap as BM import Data.Maybe (mapMaybe) import qualified Data.Text as T +import qualified Deque.Strict as D import Text.XML.Light.Input (parseXML) import Text.XML.Light.Types (Content (Elem), Element (elName), QName (qName)) import Transaq (AllTradesTrade (..), - Candle (..), + Candle (..), ClientData (..), CommandConnect (..), CommandDisconnect (CommandDisconnect), CommandGetHistoryData (CommandGetHistoryData), @@ -51,32 +54,45 @@ import Transaq (AllTradesTrade (..), ConnectionState (Disconnected), Language (LanguageEn), MarketInfo (..), + OrderNotification (..), + OrderStatus (..), Quotation (..), ResponseAllTrades (ResponseAllTrades), ResponseCandleKinds (ResponseCandleKinds), ResponseCandles (..), ResponseCandlesStatus (StatusPending), + ResponseClient (ResponseClient), ResponseMarkets (ResponseMarkets), + ResponseOrders (ResponseOrders), ResponseQuotations (ResponseQuotations), ResponseQuotes (ResponseQuotes), + ResponseResult (..), ResponseSecurities (ResponseSecurities), + ResponseTrades (ResponseTrades), Security (..), SecurityId (..), + TradeNotification (..), TransaqCommand (toXml), TransaqResponse (..), TransaqResponse (..), TransaqResponseC (fromXml), - kCandleKindId, kPeriod, state, - status) + UnfilledAction (..), + kCandleKindId, kPeriod, state) import TXML (LogLevel, freeCallback, initialize, sendCommand, setCallback) +import ATrade.Broker.Backend (BrokerBackend (..), + BrokerBackendNotification (..)) import ATrade.QuoteSource.Server (QuoteSourceServerData (..)) import ATrade.Types (Bar (..), BarTimeframe (unBarTimeframe), DataType (BestBid, BestOffer, LastTradePrice), - Tick (..), TickerId, - fromDouble) + Order (..), OrderId, + OrderPrice (..), + OrderState (..), Tick (..), + TickerId, Trade (..), + fromDouble, toDouble) +import qualified ATrade.Types as AT import Colog.Monad (WithLog) import Control.Concurrent.BoundedChan (BoundedChan, writeChan) import Control.Concurrent.STM.TMVar (TMVar) @@ -84,9 +100,11 @@ import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (ReaderT (runReaderT)) import Control.Monad.Reader.Class (MonadReader, asks) +import Data.Int (Int64) import qualified Data.Map.Strict as M import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import GHC.Exts (IsList (..)) import Prelude hiding (log) import TickerInfoServer (TickerInfo (..), TickerInfoServerHandle, @@ -115,12 +133,16 @@ data HistoryRequest = , hrReset :: Bool } deriving (Show, Eq, Ord) -newtype Request = - Request HistoryRequest - deriving (Show, Eq, Ord) +data Request = + RequestHistory HistoryRequest + | RequestSubmitOrder Order + | RequestCancelOrder OrderId + deriving (Show, Eq) data Response = ResponseHistory HistoryResponse + | ResponseOrderSubmitted + | ResponseOrderCancelled | ResponseTimeout data HistoryResponse = @@ -134,11 +156,12 @@ data HistoryResponse = data TXMLConnectorHandle = TXMLConnectorHandle { - threadId :: ThreadId - , notificationQueue :: TBQueue TransaqResponse - , hRequestVar :: TMVar Request - , hResponseVar :: TMVar (TMVar Response) - , hRequestTimestamp :: TVar UTCTime + threadId :: ThreadId + , notificationQueue :: TBQueue TransaqResponse + , hRequestVar :: TMVar Request + , hResponseVar :: TMVar (TMVar Response) + , hRequestTimestamp :: TVar UTCTime + , hNotificationCallback :: TVar (Maybe (BrokerBackendNotification -> IO ())) } data ConnectionStage = StageConnection | StageGetInfo | StageConnected @@ -147,11 +170,25 @@ data ConnectionStage = StageConnection | StageGetInfo | StageConnected data MainQueueData = MainQueueTransaqData TransaqResponse | MainQueueRequest Request - deriving (Eq, Show, Ord) + deriving (Eq, Show) data TickKey = TickKey TickerId DataType deriving (Show, Ord, Eq) +data TransactionId = + TransactionId Int64 + | ExchangeOrderId Int64 + deriving (Show, Ord, Eq) + +data BrokerState = + BrokerState + { + bsOrderTransactionIdMap :: TVar (BM.Bimap OrderId TransactionId) + , bsNotificationCallback :: TVar (Maybe (BrokerBackendNotification -> IO ())) + , bsOrderMap :: TVar (M.Map OrderId Order) + , bsPendingOrders :: TVar (D.Deque Order) + } + data Env = Env { @@ -167,6 +204,7 @@ data Env = , config :: TransaqConnectorConfig , serverConnected :: TVar ConnectionStage , candleKindMap :: TVar (M.Map Int Int) + , brokerState :: BrokerState } newtype App a = App { unApp :: ReaderT Env IO a } @@ -192,6 +230,18 @@ start logger config qssChannel tisH = do serverConnected <- liftIO $ newTVarIO StageConnection candleKindMap <- newTVarIO M.empty requestTimestamp <- getCurrentTime >>= newTVarIO + orderMap <- newTVarIO M.empty + notificationCallback <- newTVarIO Nothing + orderTransactionIdMap <- newTVarIO BM.empty + pendingOrders <- newTVarIO (fromList []) + let brokerState = + BrokerState + { + bsOrderTransactionIdMap = orderTransactionIdMap + , bsNotificationCallback = notificationCallback + , bsOrderMap = orderMap + , bsPendingOrders = pendingOrders + } let env = Env { @@ -207,6 +257,7 @@ start logger config qssChannel tisH = do , config = config , serverConnected = serverConnected , candleKindMap = candleKindMap + , brokerState = brokerState } threadId <- forkIO $ (runReaderT . unApp) workThread env return $ TXMLConnectorHandle @@ -215,6 +266,8 @@ start logger config qssChannel tisH = do , notificationQueue = notificationQueue , hRequestVar = requestVar , hResponseVar = responseVar + , hRequestTimestamp = requestTimestamp + , hNotificationCallback = notificationCallback } workThread :: App () @@ -299,8 +352,19 @@ workThread = do , hrMoreData = False } _ -> log Warning "TXMLConnector.WorkThread" "Incoming candles without response var" + TransaqResponseOrders (ResponseOrders orders) -> forM_ orders handleOrder + TransaqResponseTrades (ResponseTrades trades) -> forM_ trades handleTrade + TransaqResponseResult (ResponseSuccess (Just transactionId)) -> do + brState <- asks brokerState + liftIO $ atomically $ do + deque <- readTVar (bsPendingOrders brState) + case D.uncons deque of + Just (order, deque') -> do + writeTVar (bsPendingOrders brState) deque' + modifyTVar' (bsOrderTransactionIdMap brState) (BM.insert (orderId order) (TransactionId transactionId)) + Nothing -> pure () _ -> pure () - MainQueueRequest (Request request) -> do + MainQueueRequest (RequestHistory request) -> do cur <- asks currentCandles liftIO $ atomically $ writeTVar cur [] maybeCk <- M.lookup (unBarTimeframe . hrTimeframe $ request) <$> (asks candleKindMap >>= liftIO . readTVarIO) @@ -317,10 +381,83 @@ workThread = do } _ -> log Warning "TXMLConnector.WorkThread" $ "Unable to parse security ID: " <> hrTickerId request _ -> log Warning "TXMLConnector.WorkThread" $ "Invalid candlekind requested" <> (T.pack . show . unBarTimeframe . hrTimeframe $ request) + MainQueueRequest (RequestSubmitOrder order) -> do + case mkNewOrderCommand order of + Just cmd -> do + v <- liftIO . sendCommand . toXml $ cmd + case v of + Left err -> log Warning "TXMLConnector.WorkThread" $ "Unable to send request: [" <> err <> "]" + Right _ -> do + brState <- asks brokerState + liftIO $ atomically $ do + modifyTVar' (bsPendingOrders brState) (order `D.snoc`) + modifyTVar' (bsOrderMap brState) (M.insert (orderId order) order) + _ -> pure () + _ -> pure () + checkRequestTimeout requestTimeout = 10 + handleTrade transaqTrade = do + brState <- asks brokerState + trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState) + maybeCb <- liftIO $ readTVarIO (bsNotificationCallback brState) + orderMap <- liftIO $ readTVarIO (bsOrderMap brState) + case maybeCb of + Just cb -> case BM.lookupR (ExchangeOrderId (tOrderNo transaqTrade)) trIdMap of + Just oid -> case M.lookup oid orderMap of + Just order -> liftIO $ cb (BackendTradeNotification (fromTransaqTrade transaqTrade order)) + _ -> pure () + _ -> pure () + Nothing -> pure () + + fromTransaqTrade transaqTrade order = + Trade + { + tradeOrderId = orderId order + , tradePrice = fromDouble (tPrice transaqTrade) + , tradeQuantity = fromIntegral $ tQuantity transaqTrade + , tradeVolume = fromDouble $ tValue transaqTrade + , tradeVolumeCurrency = "" + , tradeOperation = fromDirection (tBuysell transaqTrade) + , tradeAccount = tClient transaqTrade <> "#" <> tUnion transaqTrade + , tradeSecurity = tBoard transaqTrade <> "#" <> tSecCode transaqTrade + , tradeTimestamp = tTimestamp transaqTrade + , tradeCommission = fromDouble $ tComission transaqTrade + , tradeSignalId = orderSignalId order + } + + fromDirection Transaq.Buy = AT.Buy + fromDirection Transaq.Sell = AT.Sell + + handleOrder orderUpdate = do + brState <- asks brokerState + trIdMap <- liftIO $ readTVarIO (bsOrderTransactionIdMap brState) + maybeCb <- liftIO $ readTVarIO (bsNotificationCallback brState) + case maybeCb of + Just cb -> case BM.lookupR (TransactionId (fromIntegral $ oTransactionId orderUpdate)) trIdMap of + Just oid -> liftIO $ cb (BackendOrderNotification oid (orderStateFromTransaq orderUpdate)) + _ -> pure () + Nothing -> pure () + + orderStateFromTransaq orderUpdate = + case oStatus orderUpdate of + OrderActive -> Submitted + OrderCancelled -> Cancelled + OrderDenied -> Rejected + OrderDisabled -> Rejected + OrderExpired -> Cancelled + OrderFailed -> Rejected + OrderForwarding -> Unsubmitted + OrderInactive -> OrderError + OrderMatched -> Executed + OrderRefused -> Rejected + OrderRemoved -> Rejected + OrderWait -> Unsubmitted + OrderWatching -> Unsubmitted + _ -> OrderError + checkRequestTimeout = do now <- liftIO getCurrentTime tsVar <- asks requestTimestamp @@ -381,6 +518,9 @@ workThread = do TransaqResponseSecInfo secInfo -> log Debug "TXMLConnector.WorkThread" $ "Incoming secinfo:" <> (T.pack . show) secInfo -- TODO: Pass to qtis + TransaqResponseClient (ResponseClient clientData) -> do + log Debug "TXMLConnector.WorkThread" $ + "Incoming client data: " <> (T.pack . show) (cClientId clientData) <> "#" <> (T.pack . show) (cUnion clientData) _ -> pure () handleUnconnected :: App () handleUnconnected = do @@ -494,6 +634,12 @@ parseSecurityId tickerId = case T.findIndex (== '#') tickerId of makeTickerId :: SecurityId -> TickerId makeTickerId sec = board sec <> "#" <> seccode sec +parseAccountId :: T.Text -> Maybe (T.Text, T.Text) +parseAccountId accId = case T.findIndex (== '#') accId of + Just ix -> Just (T.take ix accId, T.drop (ix + 1) accId) + Nothing -> Nothing + + makeRequest :: TXMLConnectorHandle -> Request -> IO Response makeRequest h request = do now <- getCurrentTime @@ -507,6 +653,46 @@ makeRequest h request = do void $ takeTMVar (hResponseVar h) takeTMVar resp +mkNewOrderCommand :: Order -> Maybe Transaq.CommandNewOrder +mkNewOrderCommand order = + case parseSecurityId (orderSecurity order) of + Just secId -> + case parseAccountId (orderAccountId order) of + Just (client, union) -> do + case orderPrice order of + Market -> Just $ Transaq.CommandNewOrder + { + security = secId + , client = client + , unionCode = union + , price = 0 + , quantity = fromInteger $ orderQuantity order + , buysell = toDirection $ orderOperation order + , bymarket = True + , brokerRef = T.empty + , unfilled = UnfilledPutInQueue + , usecredit = False + , nosplit = False + } + Limit price -> Just $ Transaq.CommandNewOrder + { + security = secId + , client = client + , unionCode = union + , price = toDouble price + , quantity = fromInteger $ orderQuantity order + , buysell = toDirection $ orderOperation order + , bymarket = False + , brokerRef = T.empty + , unfilled = UnfilledPutInQueue + , usecredit = False + , nosplit = False + } + _ -> Nothing + where + toDirection AT.Buy = Transaq.Buy + toDirection AT.Sell = Transaq.Sell + candleToBar :: SecurityId -> Candle -> Bar candleToBar sec candle = @@ -520,3 +706,17 @@ candleToBar sec candle = , barClose = fromDouble (cClose candle) , barVolume = fromIntegral $ cVolume candle } + +brSubmitOrder :: TXMLConnectorHandle -> Order -> IO () +brSubmitOrder h order = void $ makeRequest h (RequestSubmitOrder order) + +brCancelOrder :: TXMLConnectorHandle -> OrderId -> IO () +brCancelOrder h oid = void $ makeRequest h (RequestCancelOrder oid) + +brSetNotificationCallback :: TXMLConnectorHandle -> Maybe (BrokerBackendNotification -> IO ()) -> IO () +brSetNotificationCallback h cb = atomically $ writeTVar (hNotificationCallback h) cb + +makeBrokerBackend :: TXMLConnectorHandle -> T.Text -> BrokerBackend +makeBrokerBackend h account = + BrokerBackend [account] (brSetNotificationCallback h) (brSubmitOrder h) (brCancelOrder h) (pure ()) + diff --git a/src/Transaq.hs b/src/Transaq.hs index 29c87f9..be537b4 100644 --- a/src/Transaq.hs +++ b/src/Transaq.hs @@ -26,10 +26,14 @@ module Transaq ResponseAllTrades(..), ResponseTrades(..), ResponseQuotes(..), + ResponseOrders(..), + ResponseClient(..), + ClientData(..), Quotation(..), Quote(..), TradeNotification(..), OrderNotification(..), + OrderStatus(..), AllTradesTrade(..), Tick(..), ConnectionState(..), @@ -37,7 +41,9 @@ module Transaq Security(..), CandleKind(..), ResponseCandlesStatus(..), - Candle(..) + Candle(..), + UnfilledAction(..), + TradeDirection(..) ) where import Control.Applicative ((<|>)) @@ -253,7 +259,7 @@ data CommandNewOrder = security :: SecurityId , client :: T.Text , unionCode :: T.Text - , price :: TransaqPrice + , price :: Double , quantity :: Int , buysell :: TradeDirection , bymarket :: Bool @@ -305,7 +311,7 @@ instance TransaqCommand CommandGetSecuritiesInfo where fmap (unode "security") securities) data ResponseResult = - ResponseSuccess + ResponseSuccess (Maybe Int64) | ResponseFailure T.Text deriving (Show, Eq, Ord) @@ -314,7 +320,7 @@ instance TransaqResponseC ResponseResult where if qName (elName root) == "result" then if findAttr (blank_name {qName = "success"}) root == Just "true" - then Just ResponseSuccess + then Just $ ResponseSuccess (findAttr (uname "transactionid") root >>= readMaybe) else Just . ResponseFailure . T.pack . concatMap cdData . onlyText . elContent $ root else Nothing @@ -452,6 +458,33 @@ instance TransaqResponseC ResponseMarkets where 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 { @@ -515,7 +548,7 @@ instance TransaqResponseC ResponseSecurities where sInstrClass <- T.pack <$> childContent "instrclass" tag sBoard <- T.pack <$> childContent "board" tag sMarket <- T.pack <$> childContent "market" tag - sCurrency <- T.pack <$> childContent "currency" 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 @@ -709,42 +742,40 @@ instance TransaqResponseC ResponseQuotes where return . Just $ Quote {..} data OrderStatus = - OrderCancelled + OrderActive + | OrderCancelled | OrderDenied | OrderDisabled | OrderExpired | OrderFailed - | OrderLinkWait + | OrderForwarding + | OrderInactive + | OrderMatched + | OrderRefused | OrderRejected - | OrderSLExecuted - | OrderSLForwarding - | OrderSLGuardTime - | OrderTPCorrection - | OrderTPCorrectionGuardTime - | OrderTPExecuted - | OrderTPForwarding - | OrderTPGuardTime + | OrderRemoved + | OrderWait | 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 + 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 = @@ -757,55 +788,54 @@ instance TransaqResponseC ResponseOrders where 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 + 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 "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 + 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 { - 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 + 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 = @@ -818,18 +848,19 @@ instance TransaqResponseC ResponseTrades where 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 + 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 = @@ -854,6 +885,7 @@ newtype ResponseTicks = data TransaqResponse = TransaqResponseResult ResponseResult | TransaqResponseCandles ResponseCandles + | TransaqResponseClient ResponseClient | TransaqResponseServerStatus ResponseServerStatus | TransaqResponseMarkets ResponseMarkets | TransaqResponseCandleKinds ResponseCandleKinds @@ -870,6 +902,7 @@ 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 diff --git a/transaq-connector.cabal b/transaq-connector.cabal index f812cea..70b6a88 100644 --- a/transaq-connector.cabal +++ b/transaq-connector.cabal @@ -50,6 +50,8 @@ executable transaq-connector , mtl , vector , binary + , bimap + , deque extra-lib-dirs: lib ghc-options: -Wall -Wcompat