Fixes for paperbroker

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

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

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
+  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 $ qBid q
-  , volume = fromIntegral $ qQuantity q
-  },
-  Tick
+        , 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 $ qOffer q
-  , volume = fromIntegral $ qQuantity q
-  }]
+        , value = fromDouble offer
+        , volume = fromIntegral $ fromMaybe 0 $ qQuantity q
+        }
+      Nothing -> Nothing
 
 securityToTickerInfo :: Security -> TickerInfo
 securityToTickerInfo sec =

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)

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 =