Small refactoring

app/Main.hs

@@ -3,19 +3,24 @@ module Main where
 import Lib
 import QuoteSource.DDE
 import QuoteSource.DataImport
-import Control.Concurrent
+import Control.Concurrent hiding (readChan)
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.IORef
 import Graphics.UI.Gtk hiding (Action, backspace)
-
+import Control.Concurrent.BoundedChan
+import Data.ATrade
 
 callback :: DdeCallback
 callback = undefined
 
 main :: IO ()
 main = do
-  dis <- initDataImportServer "atrade"
+  chan <- newBoundedChan 1000
+  forkIO $ forever $ do
+    tick <- readChan chan
+    when (datatype tick == Price) $ print tick
+  dis <- initDataImportServer chan "atrade"
   void initGUI
   window <- windowNew
   window `on` deleteEvent $ do

quik-connector.cabal

@@ -18,6 +18,7 @@ library
   exposed-modules:     Lib
                      , QuoteSource.DDE
                      , QuoteSource.DataImport
+                     , Data.ATrade
   ghc-options:         -Wincomplete-patterns
   build-depends:       base >= 4.7 && < 5
                      , Win32
@@ -32,12 +33,12 @@ library
                      , containers
                      , mtl
                      , datetime
+                     , BoundedChan
   default-language:    Haskell2010
   extra-libraries:     "user32"
   other-modules:       QuoteSource.XlParser
                      , QuoteSource.TableParser
                      , QuoteSource.TableParsers.AllParamsTableParser
-                     , Data.ATrade
 
 executable quik-connector-exe
   hs-source-dirs:      app
@@ -47,6 +48,7 @@ executable quik-connector-exe
                      , quik-connector
                      , Win32
                      , gtk
+                     , BoundedChan
   default-language:    Haskell2010
   extra-libraries:     "user32"
 

src/QuoteSource/DDE.hs

@@ -2,6 +2,7 @@
 
 module QuoteSource.DDE (
   initializeDde,
+  destroyDde,
   DdeState,
   DdeCallback,
   ddeResultAck,
@@ -11,7 +12,6 @@ module QuoteSource.DDE (
   ddeXtypPoke,
   ddeCpWinAnsi,
   queryString,
-  nullDdeState,
   accessData,
   unaccessData,
   withDdeData
@@ -29,8 +29,11 @@ import Control.Applicative
 import Control.Exception
 import Control.Monad
 import Data.Bits
+import Data.Binary.Get
 import Data.Typeable
 import Data.ByteString hiding (map)
+import Data.IORef
+import QuoteSource.XlParser
 import System.Win32.DLL
 import System.Win32.Types
 import Foreign
@@ -38,6 +41,8 @@ import Foreign.C.Types
 import Foreign.C.String
 import Foreign.Marshal.Array
 
+import qualified Data.ByteString.Lazy as BL
+
 data DdeException = ApiError String
   deriving (Show, Typeable)
 
@@ -92,31 +97,76 @@ foreign import WINDOWS_CCONV "wrapper"
 
 data DdeState = DdeState {
   ddeInstance :: DWORD,
-  appName :: HANDLE,
+  appName :: String,
-  topicName :: HANDLE,
+  topic :: String,
-  callback :: FunPtr DdeCallback
+  appNameHandle :: HANDLE,
+  topicHandle :: HANDLE,
+  callback :: FunPtr DdeCallback,
+  dataCallback :: DdeDataCallback
 }
 
-nullDdeState = DdeState { ddeInstance = 0, appName = nullPtr, topicName = nullPtr, callback = nullFunPtr }
+type DdeDataCallback = String -> (Int, Int, [XlData]) -> IO Bool
-
 type DdeCallback = CUInt -> CUInt -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> LPDWORD -> LPDWORD -> IO HANDLE
 
-initializeDde :: String -> String -> DdeCallback -> IO DdeState
+{-|
-initializeDde appName topicName callback = alloca (\instancePtr -> do
+ - Callback for DDE messages
-    cb <- mkCallbackPtr callback
+ - DdeState is wrapped in IORef, because this callback should be passed to ddeInitialize, which in turn returns DDE handle
+ -}
+ddeCallback :: IORef DdeState -> CUInt -> CUInt -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> LPDWORD -> LPDWORD -> IO HANDLE
+ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2
+    | msgType == ddeXtypConnect = handleConnect state hsz1 hsz2
+    | msgType == ddeXtypPoke = handlePoke state hsz1 hData
+    | otherwise = return nullHANDLE -- Do not handle other messages, they are boring
+  where
+    handleConnect state hsz1 hsz2 = do
+      myDdeState <- readIORef state
+      maybeAppName <- queryString myDdeState 256 hsz2
+      case maybeAppName of
+        Just incomingAppName -> do
+          return $ if incomingAppName == appName myDdeState
+            then ddeResultTrue
+            else ddeResultFalse
+        Nothing -> return ddeResultFalse
+
+    handlePoke state hsz1 hData = do
+      myDdeState <- readIORef state
+      maybeTopic <- queryString myDdeState 256 hsz1
+      case maybeTopic of
+        Nothing -> return ddeResultFalse
+        Just topic -> withDdeData hData (\xlData -> case runGetOrFail xlParser $ BL.fromStrict xlData of
+          Left (_,  _, errmsg) -> return ddeResultFalse
+          Right (_, _, table) -> do
+            rc <- (dataCallback myDdeState) topic table
+            return $ if rc
+              then ddeResultAck
+              else ddeResultFalse )
+
+initializeDde :: String -> String -> DdeDataCallback -> IO (IORef DdeState)
+initializeDde appName topic callback = alloca (\instancePtr -> do
+    ddeState <- newIORef $ DdeState {
+      ddeInstance = 0,
+      appName = appName,
+      appNameHandle = nullHANDLE,
+      topic = topic,
+      topicHandle = nullHANDLE,
+      callback = nullFunPtr,
+      dataCallback = callback } 
+    cb <- mkCallbackPtr (ddeCallback ddeState)
     rc <- ddeInitialize instancePtr cb 0 0
     instanceRaw <- peek instancePtr
+    atomicModifyIORef' ddeState (\state -> (state { ddeInstance = instanceRaw, callback = cb }, ()))
     when (rc /= CUInt 0) $ throw $ ApiError "Unable to initialize DDE"
 
-    withCString appName (\appNameRaw -> withCString topicName (\topicNameRaw -> do
+    withCString appName (\appNameRaw -> withCString topic (\topicRaw -> do
-      appNameHandle <- ddeCreateStringHandle instanceRaw appNameRaw ddeCpWinAnsi
+      myAppNameHandle <- ddeCreateStringHandle instanceRaw appNameRaw ddeCpWinAnsi
-      topicNameHandle <- ddeCreateStringHandle instanceRaw topicNameRaw ddeCpWinAnsi
+      myTopicHandle <- ddeCreateStringHandle instanceRaw topicRaw ddeCpWinAnsi
-      when (appNameHandle == nullHANDLE || topicNameHandle == nullHANDLE) $ throw $ ApiError "Unable to create strings handles"
+      when (myAppNameHandle == nullHANDLE || myTopicHandle == nullHANDLE) $ throw $ ApiError "Unable to create strings handles"
 
-      rc2 <- ddeNameService instanceRaw appNameHandle nullPtr 1
+      atomicModifyIORef' ddeState (\state -> (state { appNameHandle = myAppNameHandle, topicHandle = myTopicHandle }, ()))
+      rc2 <- ddeNameService instanceRaw myAppNameHandle nullPtr 1
       when (rc2 == nullHANDLE) $ throw $ ApiError $ "Unable to register application name: " ++ appName
 
-      return DdeState { ddeInstance = instanceRaw, appName = appNameHandle, topicName = topicNameHandle, callback = cb } )))
+      return ddeState)))
 
 destroyDde :: DdeState -> IO ()
 destroyDde state = do

src/QuoteSource/DataImport.hs

@@ -2,81 +2,59 @@
 
 module QuoteSource.DataImport
 (
+  ServerState,
   initDataImportServer,
-  ServerState
+  shutdownDataImportServer
 ) where
 
-import Foreign.Marshal.Alloc
+import Control.Concurrent.BoundedChan
-import System.Win32.DLL
+import Control.Monad.State.Strict
-import System.Win32.Types
+import Data.ATrade
+import Data.IORef
+import Data.Time.Clock
 import Foreign
-import Foreign.C.Types
 import Foreign.C.String
-
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
 import QuoteSource.DDE
-import QuoteSource.XlParser
 import QuoteSource.TableParser
 import QuoteSource.TableParsers.AllParamsTableParser
-import Data.IORef
+import QuoteSource.XlParser
+import System.Win32.Types
 import Text.Printf
-import Data.Binary.Get
+
-import Data.Time.Clock
-import Control.Monad.State.Strict
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
 
 data TableParserInstance = forall a . TableParser a => MkTableParser a
-instance TableParser TableParserInstance where
-  parseXlTable = parseXlTable
-  getTableId (MkTableParser a) = getTableId a
-  giveTimestampHint (MkTableParser a) t = MkTableParser (giveTimestampHint a t)
-
 
 data ServerState = ServerState {
-  dde :: DdeState,
   appName :: String,
-  parser :: TableParserInstance
+  parsers :: IORef (M.Map String TableParserInstance),
+  tickChannel :: BoundedChan Tick
 }
 
-ddeCallback :: IORef ServerState -> CUInt -> CUInt -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> LPDWORD -> LPDWORD -> IO HANDLE
+ddeCallback :: ServerState -> String -> (Int, Int, [XlData]) -> IO Bool
-ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2
+ddeCallback state topic table = do
-    | msgType == ddeXtypConnect = handleConnect state hsz1 hsz2
+  myParsers <- readIORef $ parsers state
-    | msgType == ddeXtypPoke = handlePoke state hsz1 hData
+  case M.lookup topic myParsers of
-    | otherwise = return nullHANDLE
+    Just (MkTableParser myParser) -> do
-  where
+      timeHint <- getCurrentTime
-    handleConnect state hsz1 hsz2 = do
+      let stateWithTimeHint = giveTimestampHint myParser timeHint
-      myAppName <- appName <$> readIORef state
+      let (ticks, newState) = runState (parseXlTable table) $ stateWithTimeHint
-      myDdeState <- dde <$> readIORef state
+      modifyIORef (parsers state) (\m -> M.insert topic (MkTableParser newState) m)
-      maybeAppName <- queryString myDdeState 256 hsz2
+      writeList2Chan (tickChannel state) ticks
-      case maybeAppName of
+      return True
-        Just incomingAppName -> do
+    _ -> return False
-          putStrLn incomingAppName
+
-          return $ if incomingAppName == myAppName
+
-            then ddeResultTrue
+initDataImportServer :: BoundedChan Tick -> String -> IO (ServerState, IORef DdeState)
-            else ddeResultFalse
+initDataImportServer tickChan applicationName = do
-        Nothing -> return ddeResultFalse
+  parsers <- newIORef $ M.fromList $ map (\p -> (getTableId p, MkTableParser p)) [mkAllParamsTableParser "allparams"]
-
+  let s = ServerState { appName = applicationName, parsers = parsers, tickChannel = tickChan }
-    handlePoke state hsz1 hData = do
+  d <- initializeDde applicationName "default" (ddeCallback s)
-      myDdeState <- dde <$> readIORef state
+  return (s, d)
-      maybeTopic <- queryString myDdeState 256 hsz1
-      case maybeTopic of
-        Nothing -> return ddeResultFalse
-        Just topic -> withDdeData hData (\xlData -> case runGetOrFail xlParser $ BL.fromStrict xlData of
-          Left (_,  _, errmsg) -> return ddeResultFalse
-          Right (_, _, table) -> do
-            myParser <- parser <$> readIORef state
-            when (topic == getTableId myParser) $ do
-              timeHint <- getCurrentTime
-              modifyIORef state (\s -> s { parser = giveTimestampHint (parser s) timeHint })
-              (MkTableParser myParser) <- parser <$> readIORef state
-              let (ticks, newState) = runState (parseXlTable table) myParser
-              modifyIORef state (\s -> s { parser = MkTableParser newState })
-            return ddeResultAck)
 
+shutdownDataImportServer :: (ServerState, IORef DdeState) -> IO ()
+shutdownDataImportServer (state, dde) = readIORef dde >>= destroyDde
 
-initDataImportServer :: String -> IO (IORef ServerState)
-initDataImportServer applicationName = do
-  s <- newIORef ServerState { appName = applicationName, dde = nullDdeState, parser = MkTableParser $ mkAllParamsTableParser "allparams" }
-  d <- initializeDde applicationName "default" (ddeCallback s)
-  modifyIORef s (\state -> state {dde = d})
-  putStrLn "DataImportServer initialized"
-  return s