From 9e189da91a9d913a77c6514e7e015970aaee2e4e Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Wed, 21 Sep 2016 20:16:59 +0700 Subject: [PATCH] Small refactoring --- app/Main.hs | 11 ++-- quik-connector.cabal | 4 +- src/QuoteSource/DDE.hs | 80 +++++++++++++++++++++++------ src/QuoteSource/DataImport.hs | 96 ++++++++++++++--------------------- 4 files changed, 113 insertions(+), 78 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 8d490ed..066aafe 100644 --- a/app/Main.hs +++ b/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 diff --git a/quik-connector.cabal b/quik-connector.cabal index 443f56a..9bc870a 100644 --- a/quik-connector.cabal +++ b/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" diff --git a/src/QuoteSource/DDE.hs b/src/QuoteSource/DDE.hs index c76d31d..6123a9a 100644 --- a/src/QuoteSource/DDE.hs +++ b/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, - topicName :: HANDLE, - callback :: FunPtr DdeCallback + appName :: String, + topic :: String, + 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 - cb <- mkCallbackPtr callback +{-| + - Callback for DDE messages + - 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 - appNameHandle <- ddeCreateStringHandle instanceRaw appNameRaw ddeCpWinAnsi - topicNameHandle <- ddeCreateStringHandle instanceRaw topicNameRaw ddeCpWinAnsi - when (appNameHandle == nullHANDLE || topicNameHandle == nullHANDLE) $ throw $ ApiError "Unable to create strings handles" + withCString appName (\appNameRaw -> withCString topic (\topicRaw -> do + myAppNameHandle <- ddeCreateStringHandle instanceRaw appNameRaw ddeCpWinAnsi + myTopicHandle <- ddeCreateStringHandle instanceRaw topicRaw ddeCpWinAnsi + 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 diff --git a/src/QuoteSource/DataImport.hs b/src/QuoteSource/DataImport.hs index 6fbceec..57b2e79 100644 --- a/src/QuoteSource/DataImport.hs +++ b/src/QuoteSource/DataImport.hs @@ -2,81 +2,59 @@ module QuoteSource.DataImport ( + ServerState, initDataImportServer, - ServerState + shutdownDataImportServer ) where -import Foreign.Marshal.Alloc -import System.Win32.DLL -import System.Win32.Types +import Control.Concurrent.BoundedChan +import Control.Monad.State.Strict +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 state msgType format hConv hsz1 hsz2 hData dwData1 dwData2 - | msgType == ddeXtypConnect = handleConnect state hsz1 hsz2 - | msgType == ddeXtypPoke = handlePoke state hsz1 hData - | otherwise = return nullHANDLE - where - handleConnect state hsz1 hsz2 = do - myAppName <- appName <$> readIORef state - myDdeState <- dde <$> readIORef state - maybeAppName <- queryString myDdeState 256 hsz2 - case maybeAppName of - Just incomingAppName -> do - putStrLn incomingAppName - return $ if incomingAppName == myAppName - then ddeResultTrue - else ddeResultFalse - Nothing -> return ddeResultFalse - - handlePoke state hsz1 hData = do - myDdeState <- dde <$> 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 - 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) +ddeCallback :: ServerState -> String -> (Int, Int, [XlData]) -> IO Bool +ddeCallback state topic table = do + myParsers <- readIORef $ parsers state + case M.lookup topic myParsers of + Just (MkTableParser myParser) -> do + timeHint <- getCurrentTime + let stateWithTimeHint = giveTimestampHint myParser timeHint + let (ticks, newState) = runState (parseXlTable table) $ stateWithTimeHint + modifyIORef (parsers state) (\m -> M.insert topic (MkTableParser newState) m) + writeList2Chan (tickChannel state) ticks + return True + _ -> return False + + +initDataImportServer :: BoundedChan Tick -> String -> IO (ServerState, IORef DdeState) +initDataImportServer tickChan applicationName = do + parsers <- newIORef $ M.fromList $ map (\p -> (getTableId p, MkTableParser p)) [mkAllParamsTableParser "allparams"] + let s = ServerState { appName = applicationName, parsers = parsers, tickChannel = tickChan } + d <- initializeDde applicationName "default" (ddeCallback s) + return (s, d) +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