asakul
/
quik-connector
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Small refactoring

master
Denis Tereshkin 9 years ago
parent
2235665fc8
commit
9e189da91a
4 changed files with 113 additions and 78 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 11
      app/Main.hs
  2. 4
      quik-connector.cabal
  3. 80
      src/QuoteSource/DDE.hs
  4. 94
      src/QuoteSource/DataImport.hs

11
app/Main.hs
Unescape View File

@ -3,19 +3,24 @@ module Main where @@ -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

4
quik-connector.cabal
Unescape View File

@ -18,6 +18,7 @@ library @@ -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 @@ -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 @@ -47,6 +48,7 @@ executable quik-connector-exe
, quik-connector
, Win32
, gtk
, BoundedChan
default-language: Haskell2010
extra-libraries: "user32"

80
src/QuoteSource/DDE.hs
Unescape View File

@ -2,6 +2,7 @@ @@ -2,6 +2,7 @@
module QuoteSource.DDE (
initializeDde,
destroyDde,
DdeState,
DdeCallback,
ddeResultAck,
@ -11,7 +12,6 @@ module QuoteSource.DDE ( @@ -11,7 +12,6 @@ module QuoteSource.DDE (
ddeXtypPoke,
ddeCpWinAnsi,
queryString,
nullDdeState,
accessData,
unaccessData,
withDdeData
@ -29,8 +29,11 @@ import Control.Applicative @@ -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 @@ -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" @@ -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

94
src/QuoteSource/DataImport.hs
Unescape View File

@ -2,81 +2,59 @@ @@ -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
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
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)
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

Write Preview
Loading…
Cancel
Save