From 3ac0129d4b7be0089caac50aca293b10fd087b8b Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 1 Oct 2016 09:36:39 +0700 Subject: [PATCH] Trying to get rid of leaks --- quik-connector.cabal | 1 + src/Broker/PaperBroker.hs | 16 ++++--- src/Broker/Protocol.hs | 44 +++++++++++++++++++ src/QuoteSource/DataImport.hs | 2 +- .../TableParsers/AllParamsTableParser.hs | 19 ++++---- 5 files changed, 65 insertions(+), 17 deletions(-) create mode 100644 src/Broker/Protocol.hs diff --git a/quik-connector.cabal b/quik-connector.cabal index 4d7ec92..6fcff29 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -43,6 +43,7 @@ library , cond , scientific , libatrade + , deepseq default-language: Haskell2010 extra-libraries: "user32" other-modules: System.Win32.XlParser diff --git a/src/Broker/PaperBroker.hs b/src/Broker/PaperBroker.hs index de5dc97..af0cc42 100644 --- a/src/Broker/PaperBroker.hs +++ b/src/Broker/PaperBroker.hs @@ -1,16 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Broker.PaperBroker ( PaperBrokerState, mkPaperBroker ) where +import Control.DeepSeq import Data.Hashable import Data.Bits import Control.Concurrent.BoundedChan import ATrade.Types import Data.IORef -import qualified Data.HashMap as M +import qualified Data.HashMap.Strict as M import qualified Data.Text as T import ATrade.Broker.Protocol import ATrade.Broker.Server @@ -20,7 +22,7 @@ import Control.Monad import Control.Concurrent hiding (readChan) import System.Log.Logger -data TickMapKey = TickMapKey T.Text DataType +data TickMapKey = TickMapKey !T.Text !DataType deriving (Show, Eq, Ord) instance Hashable TickMapKey where @@ -29,9 +31,9 @@ instance Hashable TickMapKey where data PaperBrokerState = PaperBrokerState { pbTid :: Maybe ThreadId, tickChannel :: BoundedChan Tick, - tickMap :: M.Map TickMapKey Tick, - orders :: M.Map OrderId Order, - cash :: Decimal, + tickMap :: M.HashMap TickMapKey Tick, + orders :: M.HashMap OrderId Order, + cash :: ! Decimal, orderIdCounter :: OrderId, notificationCallback :: Maybe (Notification -> IO ()) } @@ -62,9 +64,9 @@ brokerThread state = do chan <- tickChannel <$> readIORef state forever $ do tick <- readChan chan - atomicModifyIORef' state (\s -> (s { tickMap = M.insert (makeKey tick) tick (tickMap s) }, ()) ) + atomicModifyIORef' state (\s -> (s { tickMap = M.insert (makeKey tick) tick $! tickMap s }, ()) ) where - makeKey tick = TickMapKey (security tick) (datatype tick) + makeKey !tick = TickMapKey (security $! tick) (datatype tick) nextOrderId :: IORef PaperBrokerState -> IO OrderId nextOrderId state = do diff --git a/src/Broker/Protocol.hs b/src/Broker/Protocol.hs new file mode 100644 index 0000000..44ba78c --- /dev/null +++ b/src/Broker/Protocol.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Broker.Protocol ( +) where + +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Aeson +import Data.Int +import Broker + +type RequestSqnum = Int64 + +data BrokerServerRequest = RequestSubmitOrder RequestSqnum Order + | RequestCancelOrder RequestSqnum OrderId + | RequestNotifications RequestSqnum + +data BrokerServerResponse = ResponseOrderSubmitted OrderId + | ResponseOrderCancelled + | ResponseNotifications [Notification] + +data Notification = OrderNotification OrderId OrderState | TradeNotification Trade + +instance FromJSON Notification where + parseJSON = withObject "notification" (\obj -> do + tradeJson <- obj .: "trade" + case tradeJson of + Just v -> parseTrade v + Nothing -> do + orderNotification <- obj .: "order-state" + case orderNotification of + Just v -> parseOrder v + Nothing -> fail "Invalid notification") + where + parseTrade v = TradeNotification <$> parseJSON v + parseOrder (Object o) = case HM.lookup "order-state" o of + Just v -> withObject "object" (\os -> do + oid <- os .: "order-id" + ns <- os .: "new-state" + return $ OrderNotification oid ns) v + Nothing -> fail "Should be order-state" + +instance ToJSON Notification where + toJSON (OrderNotification oid diff --git a/src/QuoteSource/DataImport.hs b/src/QuoteSource/DataImport.hs index 840d57e..8a20f72 100644 --- a/src/QuoteSource/DataImport.hs +++ b/src/QuoteSource/DataImport.hs @@ -31,7 +31,7 @@ ddeCallback state topic table = do timeHint <- getCurrentTime let stateWithTimeHint = giveTimestampHint myParser timeHint let (ticks, newState) = runState (parseXlTable table) stateWithTimeHint - modifyIORef (parsers state) (M.insert topic (MkTableParser newState)) + modifyIORef' (parsers state) (\s -> newState `seq` s `seq` M.insert topic (MkTableParser newState) s) writeList2Chan (tickChannel state) ticks return True _ -> return False diff --git a/src/QuoteSource/TableParsers/AllParamsTableParser.hs b/src/QuoteSource/TableParsers/AllParamsTableParser.hs index 0a14901..14322c7 100644 --- a/src/QuoteSource/TableParsers/AllParamsTableParser.hs +++ b/src/QuoteSource/TableParsers/AllParamsTableParser.hs @@ -5,13 +5,14 @@ module QuoteSource.TableParsers.AllParamsTableParser ( mkAllParamsTableParser ) where -import qualified Data.Map.Lazy as M +import qualified Data.Map.Strict as M import QuoteSource.TableParser import ATrade.Types import System.Win32.XlParser import Data.Tuple import Data.Decimal import Control.Monad.State.Strict +import Control.DeepSeq import Data.Time.Clock import Data.Maybe import Data.DateTime @@ -82,8 +83,8 @@ safeAt list index = if index < 0 || index >= length list parseWithSchema :: TableSchema -> (Int, Int, [XlData]) -> State AllParamsTableParser [Tick] parseWithSchema sch (width, height, cells) = do - ticks <- mapM parseRow $ groupByN width $ cells - return $ concat ticks + ticks <- mapM parseRow $ groupByN width cells + return . concat $ ticks where parseRow :: [XlData] -> State AllParamsTableParser [Tick] parseRow row = case (getClassCode row, getTicker row) of @@ -102,10 +103,10 @@ parseWithSchema sch (width, height, cells) = do Just (XlDouble value) -> do ts <- gets timestampHint return $ Just Tick { - security = securityName classCode ticker, + security = force $ securityName classCode ticker, datatype = columnToDataType columnType, timestamp = ts, - value = realFracToDecimal 10 value, + value = force $ realFracToDecimal 10 value, volume = 0 } _ -> return Nothing @@ -119,10 +120,10 @@ parseWithSchema sch (width, height, cells) = do then do ts <- gets timestampHint return $ Just Tick { - security = securityName classCode ticker, + security = force $ securityName classCode ticker, datatype = Price, timestamp = ts, - value = realFracToDecimal 10 value, + value = force $ realFracToDecimal 10 value, volume = tickVolume} else return Nothing @@ -137,10 +138,10 @@ parseWithSchema sch (width, height, cells) = do let intVolume = round volume case M.lookup secname oldVolumes of Nothing -> do - modify (\s -> s { volumes = M.insert secname intVolume oldVolumes } ) + modify (\s -> s { volumes = oldVolumes `seq` M.insert secname intVolume oldVolumes } ) return 1 Just oldVolume -> do - modify (\s -> s { volumes = M.insert secname intVolume oldVolumes } ) + modify (\s -> s { volumes = oldVolumes `seq` M.insert secname intVolume oldVolumes } ) return $ if intVolume > oldVolume then intVolume - oldVolume else if intVolume < oldVolume