From 1c47c09bba2ddf5c9bacf20638ab50f5d931bca0 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Fri, 15 Dec 2023 22:54:57 +0700 Subject: [PATCH] Fixes for paperbroker --- src/Main.hs | 1 + src/PaperBroker.hs | 12 ++++--- src/TXMLConnector/Internal.hs | 44 ++++++++++++++---------- src/TickTable.hs | 4 ++- src/Transaq.hs | 64 +++++++++++++++++------------------ 5 files changed, 71 insertions(+), 54 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index f469704..658dc5a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -69,6 +69,7 @@ forkQssChannel chan = do tid <- fork $ forever $ do x <- readChan chan writeChan ch1 x + emitEvent "fork_tick" case x of QSSTick tick -> writeChan ch2 tick _ -> return () diff --git a/src/PaperBroker.hs b/src/PaperBroker.hs index 124d462..86de782 100644 --- a/src/PaperBroker.hs +++ b/src/PaperBroker.hs @@ -26,6 +26,7 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time.Clock +import Debug.EventCounters (emitEvent) import Language.Haskell.Printf (t) import System.ZMQ4 import TickerInfoServer @@ -76,7 +77,7 @@ mkPaperBroker tickTableH tisH tickChan startCash accounts comms l = do tisH = tisH } - tid <- forkIO $ brokerThread tickChan state + tid <- forkIO $ brokerThread tickChan state tickTableH atomicModifyIORef' state (\s -> (s { pbTid = Just tid }, ())) return BrokerBackend { @@ -87,8 +88,9 @@ mkPaperBroker tickTableH tisH tickChan startCash accounts comms l = do stop = pbDestroyBroker state } -brokerThread :: BoundedChan Tick -> IORef PaperBrokerState -> IO () -brokerThread chan state = forever $ do +brokerThread :: BoundedChan Tick -> IORef PaperBrokerState -> TickTable -> IO () +brokerThread chan state tickTableH = forever $ do + emitEvent "paperbroker_tick" tick <- readChan chan marketOpenTime' <- marketOpenTime <$> readIORef state when ((utctDayTime . timestamp) tick >= marketOpenTime') $ @@ -208,7 +210,9 @@ pbSubmitOrder state order = do tm <- tickTable <$> readIORef state tickMb <- lookupTick tm (orderSecurity order) orderDatatype 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 then do maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Submitted diff --git a/src/TXMLConnector/Internal.hs b/src/TXMLConnector/Internal.hs index 6113233..1632c5a 100644 --- a/src/TXMLConnector/Internal.hs +++ b/src/TXMLConnector/Internal.hs @@ -33,8 +33,9 @@ import Control.Concurrent.STM.TBQueue (TBQueue, flushTBQueue, import Control.Monad (forM_, void, when) import Control.Monad.Extra (whileM) import qualified Data.Bimap as BM -import Data.Maybe (mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Text as T +import Debug.EventCounters (emitEvent) import qualified Deque.Strict as D import SlaveThread (fork) import Text.XML.Light.Input (parseXML) @@ -255,12 +256,14 @@ handleTransaqData transaqData = do TransaqResponseAllTrades (ResponseAllTrades trades) -> do qssChan <- asks qssChannel let ticks = fmap allTradeToTick trades + liftIO $ emitEvent "txml_tick" liftIO $ forM_ ticks (writeChan qssChan . QSSTick) liftIO $ forM_ ticks (insertTick tm) pure Nothing TransaqResponseQuotations (ResponseQuotations quotations') -> do qssChan <- asks qssChannel now <- liftIO getCurrentTime + liftIO $ emitEvent "txml_quotation" let ticks = concatMap (quotationToTicks now) quotations' liftIO $ forM_ ticks (writeChan qssChan . QSSTick) liftIO $ forM_ ticks (insertTick tm) @@ -632,22 +635,29 @@ allTradeToTick att = quotationToTicks :: UTCTime -> Quotation -> [Tick] quotationToTicks timestamp' q = - let security' = qBoard q <> "#" <> qSeccode q in - [ - Tick - { security = security' - , datatype = BestBid - , timestamp = timestamp' - , value = fromDouble $ qBid q - , volume = fromIntegral $ qQuantity q - }, - Tick - { security = security' - , datatype = BestOffer - , timestamp = timestamp' - , value = fromDouble $ qOffer q - , volume = fromIntegral $ qQuantity q - }] + catMaybes [ maybeBid, maybeOffer ] + where + security' = qBoard q <> "#" <> qSeccode q + maybeBid = case qBid q of + Just bid -> + Just $ Tick + { security = security' + , datatype = BestBid + , timestamp = timestamp' + , value = fromDouble bid + , volume = fromIntegral $ fromMaybe 0 $ qQuantity q + } + Nothing -> Nothing + maybeOffer = case qOffer q of + 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 sec = diff --git a/src/TickTable.hs b/src/TickTable.hs index 10c02e7..d41ebec 100644 --- a/src/TickTable.hs +++ b/src/TickTable.hs @@ -16,6 +16,7 @@ import Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO, import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.STM (atomically) import qualified Data.Map.Strict as M +import Debug.EventCounters (emitEvent) data TickKey = TickKey TickerId DataType deriving (Show, Ord, Eq) @@ -32,7 +33,8 @@ newTickTable = do pure TickTable{..} 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) lookupTick :: (MonadIO m) => TickTable -> TickerId -> DataType -> m (Maybe Tick) diff --git a/src/Transaq.hs b/src/Transaq.hs index 7744dcc..5eb809d 100644 --- a/src/Transaq.hs +++ b/src/Transaq.hs @@ -622,23 +622,23 @@ data 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 + , qOpen :: !(Maybe Double) + , qWaprice :: !(Maybe Double) + , qBidDepth :: !(Maybe Int) + , qBidDepthT :: !(Maybe Int) + , qNumBids :: !(Maybe Int) + , qOfferDepth :: !(Maybe Int) + , qOfferDepthT :: !(Maybe Int) + , qBid :: !(Maybe Double) + , qOffer :: !(Maybe Double) + , qNumOffers :: !(Maybe Int) + , qNumTrades :: !(Maybe Int) + , qVolToday :: !(Maybe Int) + , qOpenPositions :: !(Maybe Int) + , qLastPrice :: !(Maybe Double) + , qQuantity :: !(Maybe Int) , qTimestamp :: !UTCTime - , qValToday :: !Double + , qValToday :: !(Maybe Double) } deriving (Show, Eq, Ord) newtype ResponseQuotations = @@ -654,23 +654,23 @@ instance TransaqResponseC ResponseQuotations where !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 + let !qOpen = childContent "open" tag >>= readMaybe + let !qWaprice = childContent "waprice" tag >>= readMaybe + let !qBidDepth = childContent "biddepth" tag >>= readMaybe + let !qBidDepthT = childContent "biddeptht" tag >>= readMaybe + let !qNumBids = childContent "numbids" tag >>= readMaybe + let !qBid = childContent "bid" tag >>= readMaybe + let !qOfferDepth = childContent "offerdepth" tag >>= readMaybe + let !qOfferDepthT = childContent "offerdeptht" tag >>= readMaybe + let !qNumOffers = childContent "numoffers" tag >>= readMaybe + let !qOffer = childContent "offer" tag >>= readMaybe + let !qNumTrades = childContent "numtrades" tag >>= readMaybe + let !qVolToday = childContent "voltoday" tag >>= readMaybe + let !qOpenPositions = childContent "openpositions" tag >>= readMaybe + let !qLastPrice = childContent "last" tag >>= readMaybe + let !qQuantity = childContent "quantity" tag >>= readMaybe !qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack) - !qValToday <- childContent "valToday" tag >>= readMaybe + let !qValToday = childContent "valToday" tag >>= readMaybe pure $ Just Quotation {..} data TradingPeriod =