asakul
/
transaq-connector
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

brokerserver backend

master
Denis Tereshkin 3 years ago
parent
bc197a16e4
commit
fcb25fdea4
6 changed files with 352 additions and 104 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1
      src/Config.hs
  2. 2
      src/HistoryProviderServer.hs
  3. 16
      src/Main.hs
  4. 230
      src/TXMLConnector.hs
  5. 205
      src/Transaq.hs
  6. 2
      transaq-connector.cabal

1
src/Config.hs
Unescape View File

@ -24,6 +24,7 @@ data TransaqConnectorConfig = TransaqConnectorConfig {
brokerClientCertificateDir :: Maybe FilePath, brokerClientCertificateDir :: Maybe FilePath,
tisEndpoint :: T.Text, tisEndpoint :: T.Text,
historyProviderEndpoint :: T.Text, historyProviderEndpoint :: T.Text,
account :: T.Text,
transaqLogin :: T.Text, transaqLogin :: T.Text,
transaqPassword :: T.Text, transaqPassword :: T.Text,
transaqHost :: T.Text, transaqHost :: T.Text,

2
src/HistoryProviderServer.hs
Unescape View File

@ -232,7 +232,7 @@ workThread = do
let count = truncate diff `div` periodToSeconds (rqPeriod request) let count = truncate diff `div` periodToSeconds (rqPeriod request)
log Debug "HistoryProviderServer.WorkThread" $ "Requesting bars: " <> (T.pack . show) count log Debug "HistoryProviderServer.WorkThread" $ "Requesting bars: " <> (T.pack . show) count
txml <- asks eTxml txml <- asks eTxml
response <- liftIO . makeRequest txml $ Request HistoryRequest response <- liftIO . makeRequest txml $ RequestHistory HistoryRequest
{ {
hrTickerId = rqTicker request hrTickerId = rqTicker request
, hrTimeframe = BarTimeframe . periodToSeconds . rqPeriod $ request , hrTimeframe = BarTimeframe . periodToSeconds . rqPeriod $ request

16
src/Main.hs
Unescape View File

@ -3,6 +3,9 @@ module Main (main) where
import ATrade (libatrade_gitrev, import ATrade (libatrade_gitrev,
libatrade_version) libatrade_version)
import ATrade.Broker.Protocol (NotificationSqnum (NotificationSqnum))
import ATrade.Broker.Server (startBrokerServer,
stopBrokerServer)
import ATrade.Logging (Message (..), Severity (Info), import ATrade.Logging (Message (..), Severity (Info),
logWith) logWith)
import ATrade.Logging (fmtMessage) import ATrade.Logging (fmtMessage)
@ -57,8 +60,17 @@ main = do
defaultServerSecurityParams) defaultServerSecurityParams)
stopQuoteSourceServer $ \_ -> withTickerInfoServer logger ctx (tisEndpoint cfg) $ \tisH -> do stopQuoteSourceServer $ \_ -> withTickerInfoServer logger ctx (tisEndpoint cfg) $ \tisH -> do
txml <- Connector.start logger cfg qssChannel tisH txml <- Connector.start logger cfg qssChannel tisH
withHistoryProviderServer ctx (historyProviderEndpoint cfg) txml logger id $ \_ -> do bracket (startBrokerServer
forever $ threadDelay 1000000 [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" log Info "main" "Shutting down"

230
src/TXMLConnector.hs
Unescape View File

@ -15,6 +15,7 @@ module TXMLConnector
, HistoryResponse(..) , HistoryResponse(..)
, makeRequest , makeRequest
, TXMLConnectorHandle , TXMLConnectorHandle
, makeBrokerBackend
) where ) where
import ATrade.Logging (Message, Severity (..), log, import ATrade.Logging (Message, Severity (..), log,
@ -36,14 +37,16 @@ import Control.Concurrent.STM (TVar, atomically, modifyTVar',
import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueue, import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueue,
readTBQueue, writeTBQueue) readTBQueue, writeTBQueue)
import Control.Monad (forever, void, when) import Control.Monad (forever, void, when)
import qualified Data.Bimap as BM
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Deque.Strict as D
import Text.XML.Light.Input (parseXML) import Text.XML.Light.Input (parseXML)
import Text.XML.Light.Types (Content (Elem), import Text.XML.Light.Types (Content (Elem),
Element (elName), Element (elName),
QName (qName)) QName (qName))
import Transaq (AllTradesTrade (..), import Transaq (AllTradesTrade (..),
Candle (..), Candle (..), ClientData (..),
CommandConnect (..), CommandConnect (..),
CommandDisconnect (CommandDisconnect), CommandDisconnect (CommandDisconnect),
CommandGetHistoryData (CommandGetHistoryData), CommandGetHistoryData (CommandGetHistoryData),
@ -51,32 +54,45 @@ import Transaq (AllTradesTrade (..),
ConnectionState (Disconnected), ConnectionState (Disconnected),
Language (LanguageEn), Language (LanguageEn),
MarketInfo (..), MarketInfo (..),
OrderNotification (..),
OrderStatus (..),
Quotation (..), Quotation (..),
ResponseAllTrades (ResponseAllTrades), ResponseAllTrades (ResponseAllTrades),
ResponseCandleKinds (ResponseCandleKinds), ResponseCandleKinds (ResponseCandleKinds),
ResponseCandles (..), ResponseCandles (..),
ResponseCandlesStatus (StatusPending), ResponseCandlesStatus (StatusPending),
ResponseClient (ResponseClient),
ResponseMarkets (ResponseMarkets), ResponseMarkets (ResponseMarkets),
ResponseOrders (ResponseOrders),
ResponseQuotations (ResponseQuotations), ResponseQuotations (ResponseQuotations),
ResponseQuotes (ResponseQuotes), ResponseQuotes (ResponseQuotes),
ResponseResult (..),
ResponseSecurities (ResponseSecurities), ResponseSecurities (ResponseSecurities),
ResponseTrades (ResponseTrades),
Security (..), SecurityId (..), Security (..), SecurityId (..),
TradeNotification (..),
TransaqCommand (toXml), TransaqCommand (toXml),
TransaqResponse (..), TransaqResponse (..),
TransaqResponse (..), TransaqResponse (..),
TransaqResponseC (fromXml), TransaqResponseC (fromXml),
kCandleKindId, kPeriod, state, UnfilledAction (..),
status) kCandleKindId, kPeriod, state)
import TXML (LogLevel, freeCallback, import TXML (LogLevel, freeCallback,
initialize, sendCommand, initialize, sendCommand,
setCallback) setCallback)
import ATrade.Broker.Backend (BrokerBackend (..),
BrokerBackendNotification (..))
import ATrade.QuoteSource.Server (QuoteSourceServerData (..)) import ATrade.QuoteSource.Server (QuoteSourceServerData (..))
import ATrade.Types (Bar (..), import ATrade.Types (Bar (..),
BarTimeframe (unBarTimeframe), BarTimeframe (unBarTimeframe),
DataType (BestBid, BestOffer, LastTradePrice), DataType (BestBid, BestOffer, LastTradePrice),
Tick (..), TickerId, Order (..), OrderId,
fromDouble) OrderPrice (..),
OrderState (..), Tick (..),
TickerId, Trade (..),
fromDouble, toDouble)
import qualified ATrade.Types as AT
import Colog.Monad (WithLog) import Colog.Monad (WithLog)
import Control.Concurrent.BoundedChan (BoundedChan, writeChan) import Control.Concurrent.BoundedChan (BoundedChan, writeChan)
import Control.Concurrent.STM.TMVar (TMVar) import Control.Concurrent.STM.TMVar (TMVar)
@ -84,9 +100,11 @@ import Control.Monad (forM_)
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Reader (ReaderT (runReaderT)) import Control.Monad.Reader (ReaderT (runReaderT))
import Control.Monad.Reader.Class (MonadReader, asks) import Control.Monad.Reader.Class (MonadReader, asks)
import Data.Int (Int64)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Time.Clock (UTCTime, diffUTCTime, import Data.Time.Clock (UTCTime, diffUTCTime,
getCurrentTime) getCurrentTime)
import GHC.Exts (IsList (..))
import Prelude hiding (log) import Prelude hiding (log)
import TickerInfoServer (TickerInfo (..), import TickerInfoServer (TickerInfo (..),
TickerInfoServerHandle, TickerInfoServerHandle,
@ -115,12 +133,16 @@ data HistoryRequest =
, hrReset :: Bool , hrReset :: Bool
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
newtype Request = data Request =
Request HistoryRequest RequestHistory HistoryRequest
deriving (Show, Eq, Ord) | RequestSubmitOrder Order
| RequestCancelOrder OrderId
deriving (Show, Eq)
data Response = data Response =
ResponseHistory HistoryResponse ResponseHistory HistoryResponse
| ResponseOrderSubmitted
| ResponseOrderCancelled
| ResponseTimeout | ResponseTimeout
data HistoryResponse = data HistoryResponse =
@ -134,11 +156,12 @@ data HistoryResponse =
data TXMLConnectorHandle = data TXMLConnectorHandle =
TXMLConnectorHandle TXMLConnectorHandle
{ {
threadId :: ThreadId threadId :: ThreadId
, notificationQueue :: TBQueue TransaqResponse , notificationQueue :: TBQueue TransaqResponse
, hRequestVar :: TMVar Request , hRequestVar :: TMVar Request
, hResponseVar :: TMVar (TMVar Response) , hResponseVar :: TMVar (TMVar Response)
, hRequestTimestamp :: TVar UTCTime , hRequestTimestamp :: TVar UTCTime
, hNotificationCallback :: TVar (Maybe (BrokerBackendNotification -> IO ()))
} }
data ConnectionStage = StageConnection | StageGetInfo | StageConnected data ConnectionStage = StageConnection | StageGetInfo | StageConnected
@ -147,11 +170,25 @@ data ConnectionStage = StageConnection | StageGetInfo | StageConnected
data MainQueueData = data MainQueueData =
MainQueueTransaqData TransaqResponse MainQueueTransaqData TransaqResponse
| MainQueueRequest Request | MainQueueRequest Request
deriving (Eq, Show, Ord) deriving (Eq, Show)
data TickKey = TickKey TickerId DataType data TickKey = TickKey TickerId DataType
deriving (Show, Ord, Eq) 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 = data Env =
Env Env
{ {
@ -167,6 +204,7 @@ data Env =
, config :: TransaqConnectorConfig , config :: TransaqConnectorConfig
, serverConnected :: TVar ConnectionStage , serverConnected :: TVar ConnectionStage
, candleKindMap :: TVar (M.Map Int Int) , candleKindMap :: TVar (M.Map Int Int)
, brokerState :: BrokerState
} }
newtype App a = App { unApp :: ReaderT Env IO a } newtype App a = App { unApp :: ReaderT Env IO a }
@ -192,6 +230,18 @@ start logger config qssChannel tisH = do
serverConnected <- liftIO $ newTVarIO StageConnection serverConnected <- liftIO $ newTVarIO StageConnection
candleKindMap <- newTVarIO M.empty candleKindMap <- newTVarIO M.empty
requestTimestamp <- getCurrentTime >>= newTVarIO 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 = let env =
Env Env
{ {
@ -207,6 +257,7 @@ start logger config qssChannel tisH = do
, config = config , config = config
, serverConnected = serverConnected , serverConnected = serverConnected
, candleKindMap = candleKindMap , candleKindMap = candleKindMap
, brokerState = brokerState
} }
threadId <- forkIO $ (runReaderT . unApp) workThread env threadId <- forkIO $ (runReaderT . unApp) workThread env
return $ TXMLConnectorHandle return $ TXMLConnectorHandle
@ -215,6 +266,8 @@ start logger config qssChannel tisH = do
, notificationQueue = notificationQueue , notificationQueue = notificationQueue
, hRequestVar = requestVar , hRequestVar = requestVar
, hResponseVar = responseVar , hResponseVar = responseVar
, hRequestTimestamp = requestTimestamp
, hNotificationCallback = notificationCallback
} }
workThread :: App () workThread :: App ()
@ -299,8 +352,19 @@ workThread = do
, hrMoreData = False , hrMoreData = False
} }
_ -> log Warning "TXMLConnector.WorkThread" "Incoming candles without response var" _ -> 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 () _ -> pure ()
MainQueueRequest (Request request) -> do MainQueueRequest (RequestHistory request) -> do
cur <- asks currentCandles cur <- asks currentCandles
liftIO $ atomically $ writeTVar cur [] liftIO $ atomically $ writeTVar cur []
maybeCk <- M.lookup (unBarTimeframe . hrTimeframe $ request) <$> (asks candleKindMap >>= liftIO . readTVarIO) 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" $ "Unable to parse security ID: " <> hrTickerId request
_ -> log Warning "TXMLConnector.WorkThread" $ "Invalid candlekind requested" <> (T.pack . show . unBarTimeframe . hrTimeframe $ 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 checkRequestTimeout
requestTimeout = 10 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 checkRequestTimeout = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
tsVar <- asks requestTimestamp tsVar <- asks requestTimestamp
@ -381,6 +518,9 @@ workThread = do
TransaqResponseSecInfo secInfo -> TransaqResponseSecInfo secInfo ->
log Debug "TXMLConnector.WorkThread" $ "Incoming secinfo:" <> (T.pack . show) secInfo log Debug "TXMLConnector.WorkThread" $ "Incoming secinfo:" <> (T.pack . show) secInfo
-- TODO: Pass to qtis -- 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 () _ -> pure ()
handleUnconnected :: App () handleUnconnected :: App ()
handleUnconnected = do handleUnconnected = do
@ -494,6 +634,12 @@ parseSecurityId tickerId = case T.findIndex (== '#') tickerId of
makeTickerId :: SecurityId -> TickerId makeTickerId :: SecurityId -> TickerId
makeTickerId sec = board sec <> "#" <> seccode sec 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 :: TXMLConnectorHandle -> Request -> IO Response
makeRequest h request = do makeRequest h request = do
now <- getCurrentTime now <- getCurrentTime
@ -507,6 +653,46 @@ makeRequest h request = do
void $ takeTMVar (hResponseVar h) void $ takeTMVar (hResponseVar h)
takeTMVar resp 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 :: SecurityId -> Candle -> Bar
candleToBar sec candle = candleToBar sec candle =
@ -520,3 +706,17 @@ candleToBar sec candle =
, barClose = fromDouble (cClose candle) , barClose = fromDouble (cClose candle)
, barVolume = fromIntegral $ cVolume 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 ())

205
src/Transaq.hs
Unescape View File

@ -26,10 +26,14 @@ module Transaq
ResponseAllTrades(..), ResponseAllTrades(..),
ResponseTrades(..), ResponseTrades(..),
ResponseQuotes(..), ResponseQuotes(..),
ResponseOrders(..),
ResponseClient(..),
ClientData(..),
Quotation(..), Quotation(..),
Quote(..), Quote(..),
TradeNotification(..), TradeNotification(..),
OrderNotification(..), OrderNotification(..),
OrderStatus(..),
AllTradesTrade(..), AllTradesTrade(..),
Tick(..), Tick(..),
ConnectionState(..), ConnectionState(..),
@ -37,7 +41,9 @@ module Transaq
Security(..), Security(..),
CandleKind(..), CandleKind(..),
ResponseCandlesStatus(..), ResponseCandlesStatus(..),
Candle(..) Candle(..),
UnfilledAction(..),
TradeDirection(..)
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
@ -253,7 +259,7 @@ data CommandNewOrder =
security :: SecurityId security :: SecurityId
, client :: T.Text , client :: T.Text
, unionCode :: T.Text , unionCode :: T.Text
, price :: TransaqPrice , price :: Double
, quantity :: Int , quantity :: Int
, buysell :: TradeDirection , buysell :: TradeDirection
, bymarket :: Bool , bymarket :: Bool
@ -305,7 +311,7 @@ instance TransaqCommand CommandGetSecuritiesInfo where
fmap (unode "security") securities) fmap (unode "security") securities)
data ResponseResult = data ResponseResult =
ResponseSuccess ResponseSuccess (Maybe Int64)
| ResponseFailure T.Text | ResponseFailure T.Text
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -314,7 +320,7 @@ instance TransaqResponseC ResponseResult where
if qName (elName root) == "result" if qName (elName root) == "result"
then then
if findAttr (blank_name {qName = "success"}) root == Just "true" 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 Just . ResponseFailure . T.pack . concatMap cdData . onlyText . elContent $ root
else Nothing else Nothing
@ -452,6 +458,33 @@ instance TransaqResponseC ResponseMarkets where
pure $ Just $ MarketInfo {..} pure $ Just $ MarketInfo {..}
else pure Nothing 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 = data CandleKind =
CandleKind CandleKind
{ {
@ -515,7 +548,7 @@ instance TransaqResponseC ResponseSecurities where
sInstrClass <- T.pack <$> childContent "instrclass" tag sInstrClass <- T.pack <$> childContent "instrclass" tag
sBoard <- T.pack <$> childContent "board" tag sBoard <- T.pack <$> childContent "board" tag
sMarket <- T.pack <$> childContent "market" 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 sShortName <- T.pack <$> childContent "shortname" tag
sDecimals <- childContent "decimals" tag >>= readMaybe sDecimals <- childContent "decimals" tag >>= readMaybe
sMinStep <- childContent "minstep" tag >>= readMaybe sMinStep <- childContent "minstep" tag >>= readMaybe
@ -709,42 +742,40 @@ instance TransaqResponseC ResponseQuotes where
return . Just $ Quote {..} return . Just $ Quote {..}
data OrderStatus = data OrderStatus =
OrderCancelled OrderActive
| OrderCancelled
| OrderDenied | OrderDenied
| OrderDisabled | OrderDisabled
| OrderExpired | OrderExpired
| OrderFailed | OrderFailed
| OrderLinkWait | OrderForwarding
| OrderInactive
| OrderMatched
| OrderRefused
| OrderRejected | OrderRejected
| OrderSLExecuted | OrderRemoved
| OrderSLForwarding | OrderWait
| OrderSLGuardTime
| OrderTPCorrection
| OrderTPCorrectionGuardTime
| OrderTPExecuted
| OrderTPForwarding
| OrderTPGuardTime
| OrderWatching | OrderWatching
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
data OrderNotification = data OrderNotification =
OrderNotification OrderNotification
{ {
transactionId :: Int oTransactionId :: Int
, orderNo :: Int64 , oOrderNo :: Int64
, secId :: Int , oSecId :: Int
, board :: T.Text , oBoard :: T.Text
, secCode :: T.Text , oSecCode :: T.Text
, client :: T.Text , oClient :: T.Text
, union :: T.Text , oUnion :: T.Text
, status :: OrderStatus , oStatus :: OrderStatus
, buysell :: TradeDirection , oBuysell :: TradeDirection
, timestamp :: UTCTime , oTimestamp :: UTCTime
, brokerRef :: T.Text , oBrokerRef :: T.Text
, balance :: Int , oBalance :: Int
, price :: Double , oPrice :: Double
, quantity :: Int , oQuantity :: Int
, result :: T.Text , oResult :: T.Text
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
newtype ResponseOrders = newtype ResponseOrders =
@ -757,55 +788,54 @@ instance TransaqResponseC ResponseOrders where
pure . ResponseOrders . catMaybes $ quotes pure . ResponseOrders . catMaybes $ quotes
where where
parseOrder tag = do parseOrder tag = do
transactionId <- findAttr (uname "transactionid") tag >>= readMaybe oTransactionId <- findAttr (uname "transactionid") tag >>= readMaybe
orderNo <- childContent "orderno" tag >>= readMaybe oOrderNo <- childContent "orderno" tag >>= readMaybe
secId <- childContent "secid" tag >>= readMaybe oSecId <- childContent "secid" tag >>= readMaybe
board <- T.pack <$> childContent "board" tag oBoard <- T.pack <$> childContent "board" tag
secCode <- T.pack <$> childContent "seccode" tag oSecCode <- T.pack <$> childContent "seccode" tag
client <- T.pack <$> childContent "client" tag oClient <- T.pack <$> childContent "client" tag
union <- T.pack <$> childContent "union" tag oUnion <- T.pack <$> childContent "union" tag
status <- childContent "status" tag >>= parseStatus oStatus <- childContent "status" tag >>= parseStatus
buysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack oBuysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack
timestamp <- childContent "time" tag >>= parseTimestamp . T.pack oTimestamp <- childContent "time" tag >>= parseTimestamp . T.pack
brokerRef <- T.pack <$> childContent "brokerref" tag oBrokerRef <- T.pack <$> childContent "brokerref" tag
balance <- childContent "balance" tag >>= readMaybe oBalance <- childContent "balance" tag >>= readMaybe
price <- childContent "price" tag >>= readMaybe oPrice <- childContent "price" tag >>= readMaybe
quantity <- childContent "quantity" tag >>= readMaybe oQuantity <- childContent "quantity" tag >>= readMaybe
result <- T.pack <$> childContent "result" tag oResult <- T.pack <$> childContent "result" tag
return . Just $ OrderNotification {..} return . Just $ OrderNotification {..}
parseStatus "cancelled" = Just OrderCancelled parseStatus "active" = Just OrderActive
parseStatus "denied" = Just OrderDenied parseStatus "cancelled" = Just OrderCancelled
parseStatus "disabled" = Just OrderDisabled parseStatus "denied" = Just OrderDenied
parseStatus "expired" = Just OrderExpired parseStatus "disabled" = Just OrderDisabled
parseStatus "failed" = Just OrderFailed parseStatus "expired" = Just OrderExpired
parseStatus "linkwait" = Just OrderLinkWait parseStatus "failed" = Just OrderFailed
parseStatus "rejected" = Just OrderRejected parseStatus "forwarding" = Just OrderForwarding
parseStatus "sl_executed" = Just OrderSLExecuted parseStatus "inactive" = Just OrderInactive
parseStatus "sl_forwarding" = Just OrderSLForwarding parseStatus "matched" = Just OrderMatched
parseStatus "sl_guardtime" = Just OrderSLGuardTime parseStatus "refused" = Just OrderRefused
parseStatus "tp_correction" = Just OrderTPCorrection parseStatus "rejected" = Just OrderRejected
parseStatus "tp_correction_guardtime" = Just OrderTPCorrectionGuardTime parseStatus "removed" = Just OrderRemoved
parseStatus "tp_executed" = Just OrderTPExecuted parseStatus "wait" = Just OrderWait
parseStatus "tp_forwarding" = Just OrderTPForwarding parseStatus "watching" = Just OrderWatching
parseStatus "tp_guardtime" = Just OrderTPGuardTime parseStatus _ = Nothing
parseStatus "watching" = Just OrderWatching
parseStatus _ = Nothing
data TradeNotification = data TradeNotification =
TradeNotification TradeNotification
{ {
secId :: Int tSecId :: Int
, tradeNo :: Int64 , tTradeNo :: Int64
, orderNo :: Int64 , tOrderNo :: Int64
, board :: T.Text , tBoard :: T.Text
, secCode :: T.Text , tSecCode :: T.Text
, client :: T.Text , tClient :: T.Text
, union :: T.Text , tUnion :: T.Text
, buysell :: TradeDirection , tBuysell :: TradeDirection
, timestamp :: UTCTime , tTimestamp :: UTCTime
, value :: Double , tValue :: Double
, comission :: Double , tComission :: Double
, price :: Double , tQuantity :: Int
, tPrice :: Double
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
newtype ResponseTrades = newtype ResponseTrades =
@ -818,18 +848,19 @@ instance TransaqResponseC ResponseTrades where
pure . ResponseTrades . catMaybes $ quotes pure . ResponseTrades . catMaybes $ quotes
where where
parseTrade tag = do parseTrade tag = do
secId <- childContent "secid" tag >>= readMaybe tSecId <- childContent "secid" tag >>= readMaybe
tradeNo <- childContent "tradeno" tag >>= readMaybe tTradeNo <- childContent "tradeno" tag >>= readMaybe
orderNo <- childContent "orderno" tag >>= readMaybe tOrderNo <- childContent "orderno" tag >>= readMaybe
board <- T.pack <$> childContent "board" tag tBoard <- T.pack <$> childContent "board" tag
secCode <- T.pack <$> childContent "seccode" tag tSecCode <- T.pack <$> childContent "seccode" tag
client <- T.pack <$> childContent "client" tag tClient <- T.pack <$> childContent "client" tag
union <- T.pack <$> childContent "union" tag tUnion <- T.pack <$> childContent "union" tag
buysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack tBuysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack
timestamp <- childContent "time" tag >>= parseTimestamp . T.pack tTimestamp <- childContent "time" tag >>= parseTimestamp . T.pack
value <- childContent "value" tag >>= readMaybe tValue <- childContent "value" tag >>= readMaybe
comission <- childContent "comission" tag >>= readMaybe tComission <- childContent "comission" tag >>= readMaybe
price <- childContent "price" tag >>= readMaybe tQuantity <- childContent "quantity" tag >>= readMaybe
tPrice <- childContent "price" tag >>= readMaybe
pure . Just $ TradeNotification {..} pure . Just $ TradeNotification {..}
data Tick = data Tick =
@ -854,6 +885,7 @@ newtype ResponseTicks =
data TransaqResponse = data TransaqResponse =
TransaqResponseResult ResponseResult TransaqResponseResult ResponseResult
| TransaqResponseCandles ResponseCandles | TransaqResponseCandles ResponseCandles
| TransaqResponseClient ResponseClient
| TransaqResponseServerStatus ResponseServerStatus | TransaqResponseServerStatus ResponseServerStatus
| TransaqResponseMarkets ResponseMarkets | TransaqResponseMarkets ResponseMarkets
| TransaqResponseCandleKinds ResponseCandleKinds | TransaqResponseCandleKinds ResponseCandleKinds
@ -870,6 +902,7 @@ instance TransaqResponseC TransaqResponse where
fromXml root = case qName . elName $ root of fromXml root = case qName . elName $ root of
"result" -> TransaqResponseResult <$> fromXml root "result" -> TransaqResponseResult <$> fromXml root
"error" -> TransaqResponseResult <$> fromXml root "error" -> TransaqResponseResult <$> fromXml root
"client" -> TransaqResponseClient <$> fromXml root
"candles" -> TransaqResponseCandles <$> fromXml root "candles" -> TransaqResponseCandles <$> fromXml root
"server_status" -> TransaqResponseServerStatus <$> fromXml root "server_status" -> TransaqResponseServerStatus <$> fromXml root
"markets" -> TransaqResponseMarkets <$> fromXml root "markets" -> TransaqResponseMarkets <$> fromXml root

2
transaq-connector.cabal
Unescape View File

@ -50,6 +50,8 @@ executable transaq-connector
, mtl , mtl
, vector , vector
, binary , binary
, bimap
, deque
extra-lib-dirs: lib extra-lib-dirs: lib
ghc-options: -Wall ghc-options: -Wall
-Wcompat -Wcompat

Write Preview
Loading…
Cancel
Save