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

Fixes for paperbroker

master
Denis Tereshkin 2 years ago
parent
9e31193fbf
commit
1c47c09bba
5 changed files with 71 additions and 54 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/Main.hs
  2. 12
      src/PaperBroker.hs
  3. 44
      src/TXMLConnector/Internal.hs
  4. 4
      src/TickTable.hs
  5. 64
      src/Transaq.hs

1
src/Main.hs
Unescape View File

@ -69,6 +69,7 @@ forkQssChannel chan = do
tid <- fork $ forever $ do tid <- fork $ forever $ do
x <- readChan chan x <- readChan chan
writeChan ch1 x writeChan ch1 x
emitEvent "fork_tick"
case x of case x of
QSSTick tick -> writeChan ch2 tick QSSTick tick -> writeChan ch2 tick
_ -> return () _ -> return ()

12
src/PaperBroker.hs
Unescape View File

@ -26,6 +26,7 @@ import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Time.Clock import Data.Time.Clock
import Debug.EventCounters (emitEvent)
import Language.Haskell.Printf (t) import Language.Haskell.Printf (t)
import System.ZMQ4 import System.ZMQ4
import TickerInfoServer import TickerInfoServer
@ -76,7 +77,7 @@ mkPaperBroker tickTableH tisH tickChan startCash accounts comms l = do
tisH = tisH tisH = tisH
} }
tid <- forkIO $ brokerThread tickChan state tid <- forkIO $ brokerThread tickChan state tickTableH
atomicModifyIORef' state (\s -> (s { pbTid = Just tid }, ())) atomicModifyIORef' state (\s -> (s { pbTid = Just tid }, ()))
return BrokerBackend { return BrokerBackend {
@ -87,8 +88,9 @@ mkPaperBroker tickTableH tisH tickChan startCash accounts comms l = do
stop = pbDestroyBroker state } stop = pbDestroyBroker state }
brokerThread :: BoundedChan Tick -> IORef PaperBrokerState -> IO () brokerThread :: BoundedChan Tick -> IORef PaperBrokerState -> TickTable -> IO ()
brokerThread chan state = forever $ do brokerThread chan state tickTableH = forever $ do
emitEvent "paperbroker_tick"
tick <- readChan chan tick <- readChan chan
marketOpenTime' <- marketOpenTime <$> readIORef state marketOpenTime' <- marketOpenTime <$> readIORef state
when ((utctDayTime . timestamp) tick >= marketOpenTime') $ when ((utctDayTime . timestamp) tick >= marketOpenTime') $
@ -208,7 +210,9 @@ pbSubmitOrder state order = do
tm <- tickTable <$> readIORef state tm <- tickTable <$> readIORef state
tickMb <- lookupTick tm (orderSecurity order) orderDatatype tickMb <- lookupTick tm (orderSecurity order) orderDatatype
case tickMb of case tickMb of
Nothing -> rejectOrder state order Nothing -> do
log Warning "PaperBroker" $ "Unable to lookup tick in ticktable: " <> (T.pack . show) (orderSecurity order) <> "/" <> (T.pack . show) orderDatatype
rejectOrder state order
Just tick -> if orderQuantity order /= 0 Just tick -> if orderQuantity order /= 0
then do then do
maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Submitted maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Submitted

44
src/TXMLConnector/Internal.hs
Unescape View File

@ -33,8 +33,9 @@ import Control.Concurrent.STM.TBQueue (TBQueue, flushTBQueue,
import Control.Monad (forM_, void, when) import Control.Monad (forM_, void, when)
import Control.Monad.Extra (whileM) import Control.Monad.Extra (whileM)
import qualified Data.Bimap as BM import qualified Data.Bimap as BM
import Data.Maybe (mapMaybe) import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import qualified Data.Text as T import qualified Data.Text as T
import Debug.EventCounters (emitEvent)
import qualified Deque.Strict as D import qualified Deque.Strict as D
import SlaveThread (fork) import SlaveThread (fork)
import Text.XML.Light.Input (parseXML) import Text.XML.Light.Input (parseXML)
@ -255,12 +256,14 @@ handleTransaqData transaqData = do
TransaqResponseAllTrades (ResponseAllTrades trades) -> do TransaqResponseAllTrades (ResponseAllTrades trades) -> do
qssChan <- asks qssChannel qssChan <- asks qssChannel
let ticks = fmap allTradeToTick trades let ticks = fmap allTradeToTick trades
liftIO $ emitEvent "txml_tick"
liftIO $ forM_ ticks (writeChan qssChan . QSSTick) liftIO $ forM_ ticks (writeChan qssChan . QSSTick)
liftIO $ forM_ ticks (insertTick tm) liftIO $ forM_ ticks (insertTick tm)
pure Nothing pure Nothing
TransaqResponseQuotations (ResponseQuotations quotations') -> do TransaqResponseQuotations (ResponseQuotations quotations') -> do
qssChan <- asks qssChannel qssChan <- asks qssChannel
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
liftIO $ emitEvent "txml_quotation"
let ticks = concatMap (quotationToTicks now) quotations' let ticks = concatMap (quotationToTicks now) quotations'
liftIO $ forM_ ticks (writeChan qssChan . QSSTick) liftIO $ forM_ ticks (writeChan qssChan . QSSTick)
liftIO $ forM_ ticks (insertTick tm) liftIO $ forM_ ticks (insertTick tm)
@ -632,22 +635,29 @@ allTradeToTick att =
quotationToTicks :: UTCTime -> Quotation -> [Tick] quotationToTicks :: UTCTime -> Quotation -> [Tick]
quotationToTicks timestamp' q = quotationToTicks timestamp' q =
let security' = qBoard q <> "#" <> qSeccode q in catMaybes [ maybeBid, maybeOffer ]
[ where
Tick security' = qBoard q <> "#" <> qSeccode q
{ security = security' maybeBid = case qBid q of
, datatype = BestBid Just bid ->
, timestamp = timestamp' Just $ Tick
, value = fromDouble $ qBid q { security = security'
, volume = fromIntegral $ qQuantity q , datatype = BestBid
}, , timestamp = timestamp'
Tick , value = fromDouble bid
{ security = security' , volume = fromIntegral $ fromMaybe 0 $ qQuantity q
, datatype = BestOffer }
, timestamp = timestamp' Nothing -> Nothing
, value = fromDouble $ qOffer q maybeOffer = case qOffer q of
, volume = fromIntegral $ qQuantity q Just offer ->
}] Just $ Tick
{ security = security'
, datatype = BestOffer
, timestamp = timestamp'
, value = fromDouble offer
, volume = fromIntegral $ fromMaybe 0 $ qQuantity q
}
Nothing -> Nothing
securityToTickerInfo :: Security -> TickerInfo securityToTickerInfo :: Security -> TickerInfo
securityToTickerInfo sec = securityToTickerInfo sec =

4
src/TickTable.hs
Unescape View File

@ -16,6 +16,7 @@ import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO,
import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.STM (atomically) import Control.Monad.STM (atomically)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Debug.EventCounters (emitEvent)
data TickKey = TickKey TickerId DataType data TickKey = TickKey TickerId DataType
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
@ -32,7 +33,8 @@ newTickTable = do
pure TickTable{..} pure TickTable{..}
insertTick :: (MonadIO m) => TickTable -> Tick -> m () insertTick :: (MonadIO m) => TickTable -> Tick -> m ()
insertTick tickTable tick = insertTick tickTable tick = do
liftIO $ emitEvent "tick_table_tick"
liftIO . atomically $ modifyTVar' (ttMap tickTable) (M.insert (TickKey (security tick) (datatype tick)) tick) liftIO . atomically $ modifyTVar' (ttMap tickTable) (M.insert (TickKey (security tick) (datatype tick)) tick)
lookupTick :: (MonadIO m) => TickTable -> TickerId -> DataType -> m (Maybe Tick) lookupTick :: (MonadIO m) => TickTable -> TickerId -> DataType -> m (Maybe Tick)

64
src/Transaq.hs
Unescape View File

@ -622,23 +622,23 @@ data Quotation =
qSecId :: !Int qSecId :: !Int
, qBoard :: !T.Text , qBoard :: !T.Text
, qSeccode :: !T.Text , qSeccode :: !T.Text
, qOpen :: !Double , qOpen :: !(Maybe Double)
, qWaprice :: !Double , qWaprice :: !(Maybe Double)
, qBidDepth :: !Int , qBidDepth :: !(Maybe Int)
, qBidDepthT :: !Int , qBidDepthT :: !(Maybe Int)
, qNumBids :: !Int , qNumBids :: !(Maybe Int)
, qOfferDepth :: !Int , qOfferDepth :: !(Maybe Int)
, qOfferDepthT :: !Int , qOfferDepthT :: !(Maybe Int)
, qBid :: !Double , qBid :: !(Maybe Double)
, qOffer :: !Double , qOffer :: !(Maybe Double)
, qNumOffers :: !Int , qNumOffers :: !(Maybe Int)
, qNumTrades :: !Int , qNumTrades :: !(Maybe Int)
, qVolToday :: !Int , qVolToday :: !(Maybe Int)
, qOpenPositions :: !Int , qOpenPositions :: !(Maybe Int)
, qLastPrice :: !Double , qLastPrice :: !(Maybe Double)
, qQuantity :: !Int , qQuantity :: !(Maybe Int)
, qTimestamp :: !UTCTime , qTimestamp :: !UTCTime
, qValToday :: !Double , qValToday :: !(Maybe Double)
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
newtype ResponseQuotations = newtype ResponseQuotations =
@ -654,23 +654,23 @@ instance TransaqResponseC ResponseQuotations where
!qSecId <- findAttr (uname "secid") tag >>= readMaybe !qSecId <- findAttr (uname "secid") tag >>= readMaybe
!qBoard <- T.pack <$> childContent "board" tag !qBoard <- T.pack <$> childContent "board" tag
!qSeccode <- T.pack <$> childContent "seccode" tag !qSeccode <- T.pack <$> childContent "seccode" tag
!qOpen <- childContent "open" tag >>= readMaybe let !qOpen = childContent "open" tag >>= readMaybe
!qWaprice <- childContent "waprice" tag >>= readMaybe let !qWaprice = childContent "waprice" tag >>= readMaybe
!qBidDepth <- childContent "biddepth" tag >>= readMaybe let !qBidDepth = childContent "biddepth" tag >>= readMaybe
!qBidDepthT <- childContent "biddeptht" tag >>= readMaybe let !qBidDepthT = childContent "biddeptht" tag >>= readMaybe
!qNumBids <- childContent "numbids" tag >>= readMaybe let !qNumBids = childContent "numbids" tag >>= readMaybe
!qBid <- childContent "bid" tag >>= readMaybe let !qBid = childContent "bid" tag >>= readMaybe
!qOfferDepth <- childContent "offerdepth" tag >>= readMaybe let !qOfferDepth = childContent "offerdepth" tag >>= readMaybe
!qOfferDepthT <- childContent "offerdeptht" tag >>= readMaybe let !qOfferDepthT = childContent "offerdeptht" tag >>= readMaybe
!qNumOffers <- childContent "numoffers" tag >>= readMaybe let !qNumOffers = childContent "numoffers" tag >>= readMaybe
!qOffer <- childContent "offer" tag >>= readMaybe let !qOffer = childContent "offer" tag >>= readMaybe
!qNumTrades <- childContent "numtrades" tag >>= readMaybe let !qNumTrades = childContent "numtrades" tag >>= readMaybe
!qVolToday <- childContent "voltoday" tag >>= readMaybe let !qVolToday = childContent "voltoday" tag >>= readMaybe
!qOpenPositions <- childContent "openpositions" tag >>= readMaybe let !qOpenPositions = childContent "openpositions" tag >>= readMaybe
!qLastPrice <- childContent "last" tag >>= readMaybe let !qLastPrice = childContent "last" tag >>= readMaybe
!qQuantity <- childContent "quantity" tag >>= readMaybe let !qQuantity = childContent "quantity" tag >>= readMaybe
!qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack) !qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack)
!qValToday <- childContent "valToday" tag >>= readMaybe let !qValToday = childContent "valToday" tag >>= readMaybe
pure $ Just Quotation {..} pure $ Just Quotation {..}
data TradingPeriod = data TradingPeriod =

Write Preview
Loading…
Cancel
Save