Trying to get rid of leaks

quik-connector.cabal

@@ -43,6 +43,7 @@ library
                      , cond
                      , scientific
                      , libatrade
+                     , deepseq
   default-language:    Haskell2010
   extra-libraries:     "user32"
   other-modules:       System.Win32.XlParser

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,
+  tickMap :: M.HashMap TickMapKey Tick,
-  orders :: M.Map OrderId Order,
+  orders :: M.HashMap OrderId Order,
-  cash :: Decimal,
+  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

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 

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

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
+  ticks <- mapM parseRow $ groupByN width cells
-  return $ concat ticks
+  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