From ada988df9f6c649c3526962321a00df20acf6c1b Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Tue, 20 Sep 2016 17:27:53 +0700 Subject: [PATCH] Dde Import Server initial implementation --- .gitignore | 1 + app/Main.hs | 21 ++++++- quik-connector.cabal | 8 +++ src/QuoteSource/DDE.hs | 114 ++++++++++++++++++++++++++++++++++ src/QuoteSource/DataImport.hs | 60 ++++++++++++++++++ stack.yaml | 4 +- 6 files changed, 205 insertions(+), 3 deletions(-) create mode 100644 .gitignore create mode 100644 src/QuoteSource/DDE.hs create mode 100644 src/QuoteSource/DataImport.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8d98f9d --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +.* diff --git a/app/Main.hs b/app/Main.hs index de1c1ab..5b0feab 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,25 @@ module Main where import Lib +import QuoteSource.DDE +import QuoteSource.DataImport +import Control.Concurrent +import Control.Monad + +import Graphics.UI.FLTK.LowLevel.FL +import Graphics.UI.FLTK.LowLevel.FLTKHS + +callback :: DdeCallback +callback = undefined main :: IO () -main = someFunc +main = do + dis <- initDataImportServer "atrade" + forever $ threadDelay 1000 + window <- windowNew (Size (Width 320) (Height 170)) + Nothing Nothing + end window + showWidget window + _ <- run + return () + diff --git a/quik-connector.cabal b/quik-connector.cabal index 40394f1..14d745b 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -16,8 +16,13 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Lib + , QuoteSource.DDE + , QuoteSource.DataImport build-depends: base >= 4.7 && < 5 + , Win32 + , fltkhs default-language: Haskell2010 + extra-libraries: "user32" executable quik-connector-exe hs-source-dirs: app @@ -25,7 +30,9 @@ executable quik-connector-exe ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , quik-connector + , Win32 default-language: Haskell2010 + extra-libraries: "user32" test-suite quik-connector-test type: exitcode-stdio-1.0 @@ -33,6 +40,7 @@ test-suite quik-connector-test main-is: Spec.hs build-depends: base , quik-connector + , Win32 ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/QuoteSource/DDE.hs b/src/QuoteSource/DDE.hs new file mode 100644 index 0000000..389a043 --- /dev/null +++ b/src/QuoteSource/DDE.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module QuoteSource.DDE ( + initializeDde, + DdeState, + DdeCallback, + ddeResultAck, + ddeResultTrue, + ddeResultFalse, + ddeXtypConnect, + ddeXtypPoke, + ddeCpWinAnsi, + queryString, + nullDdeState +) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.Bits +import Data.Typeable +import System.Win32.DLL +import System.Win32.Types +import Foreign +import Foreign.C.Types +import Foreign.C.String + +data DdeException = ApiError String + deriving (Show, Typeable) + +ddeResultAck :: HANDLE +ddeResultAck = wordPtrToPtr $ bit 15 + +ddeResultTrue :: HANDLE +ddeResultTrue = wordPtrToPtr $ bit 1 + +ddeResultFalse :: HANDLE +ddeResultFalse = wordPtrToPtr $ bit 0 + +ddeXtypConnect :: CUInt +ddeXtypConnect = 0x1062 + +ddeXtypPoke :: CUInt +ddeXtypPoke = 0x4090 + +ddeCpWinAnsi = 1004 + +instance Exception DdeException + +foreign import stdcall unsafe "windows.h DdeInitializeW" + ddeInitialize :: LPDWORD -> FunPtr DdeCallback -> DWORD -> DWORD -> IO CUInt + +foreign import stdcall unsafe "windows.h DdeUninitialize" + ddeUninitialize :: DWORD -> IO BOOL + +foreign import stdcall unsafe "windows.h DdeCreateStringHandleW" + ddeCreateStringHandle :: DWORD -> LPSTR -> CInt -> IO HANDLE + +foreign import stdcall unsafe "windows.h DdeFreeStringHandleW" + ddeFreeStringHandle :: DWORD -> LPSTR -> IO HANDLE + +foreign import stdcall unsafe "windows.h DdeNameService" + ddeNameService :: DWORD -> HANDLE -> HANDLE -> CInt -> IO HANDLE + +foreign import stdcall unsafe "windows.h DdeCmpStringHandles" + ddeCmpStringHandles :: HANDLE -> HANDLE -> IO CInt + +foreign import stdcall unsafe "windows.h DdeQueryStringW" + ddeQueryString :: DWORD -> HANDLE -> CString -> DWORD -> CInt -> IO DWORD + +foreign import stdcall "wrapper" + mkCallbackPtr :: DdeCallback -> IO (FunPtr DdeCallback) + +data DdeState = DdeState { + ddeInstance :: DWORD, + appName :: HANDLE, + topicName :: HANDLE, + callback :: FunPtr DdeCallback +} + +nullDdeState = DdeState { ddeInstance = 0, appName = nullPtr, topicName = nullPtr, callback = nullFunPtr } + +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 + rc <- ddeInitialize instancePtr cb 0 0 + instanceRaw <- peek instancePtr + when (rc /= CUInt 0) $ throw $ ApiError "Unable to initialize DDE" + + withCString appName (\appNameRaw -> withCString topicName (\topicNameRaw -> do + appNameHandle <- ddeCreateStringHandle instanceRaw appNameRaw 0 + topicNameHandle <- ddeCreateStringHandle instanceRaw topicNameRaw 0 + when (appNameHandle == nullHANDLE || topicNameHandle == nullHANDLE) $ throw $ ApiError "Unable to create strings handles" + + rc2 <- ddeNameService instanceRaw appNameHandle nullPtr 1 + when (rc2 == nullHANDLE) $ throw $ ApiError $ "Unable to register application name: " ++ appName + + return DdeState { ddeInstance = instanceRaw, appName = appNameHandle, topicName = topicNameHandle, callback = cb } ))) + +destroyDde :: DdeState -> IO () +destroyDde state = do + freeHaskellFunPtr $ callback state + ddeUninitialize $ ddeInstance state + return () + +queryString :: DdeState -> Int -> HANDLE -> IO (Maybe String) +queryString state maxSize handle = allocaBytes maxSize (\x -> do + rc <- ddeQueryString (ddeInstance state) handle x (toEnum maxSize) ddeCpWinAnsi + if rc == 0 + then return Nothing + else Just <$> peekCAString x) + diff --git a/src/QuoteSource/DataImport.hs b/src/QuoteSource/DataImport.hs new file mode 100644 index 0000000..496354b --- /dev/null +++ b/src/QuoteSource/DataImport.hs @@ -0,0 +1,60 @@ + +module QuoteSource.DataImport +( + initDataImportServer, + ServerState +) where + +import Foreign.Marshal.Alloc +import System.Win32.DLL +import System.Win32.Types +import Foreign +import Foreign.C.Types +import Foreign.C.String + +import QuoteSource.DDE +import Data.IORef + +data ServerState = ServerState { + dde :: DdeState, + appName :: String +} + +ddeCallback :: IORef ServerState -> CUInt -> CUInt -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> LPDWORD -> LPDWORD -> IO HANDLE +ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2 = do + putStrLn "Callback" + return nullHANDLE + +{- + | msgType == ddeXtypConnect = handleConnect state hsz1 hsz2 + | msgType == ddeXtypPoke = handlePoke state hsz1 hData + | otherwise = do + print msgType + return nullHANDLE + where + handleConnect state hsz1 hsz2 = do + myAppName <- appName <$> readIORef state + myDdeState <- dde <$> readIORef state + maybeAppName <- queryString myDdeState 256 hsz2 + putStrLn "Connect" + case maybeAppName of + Just incomingAppName -> do + putStrLn incomingAppName + return $ if incomingAppName == myAppName + then ddeResultTrue + else ddeResultFalse + Nothing -> return ddeResultFalse + + handlePoke state hsz1 hData = do + putStrLn "Poke" + return ddeResultAck + -} + + +initDataImportServer :: String -> IO (IORef ServerState) +initDataImportServer applicationName = do + s <- newIORef ServerState { appName = applicationName, dde = nullDdeState } + d <- initializeDde applicationName "default" (ddeCallback s) + modifyIORef s (\state -> state {dde = d}) + putStrLn "DataImportServer initialized" + return s diff --git a/stack.yaml b/stack.yaml index 41eeaad..7c0743d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,7 +39,7 @@ packages: - '.' # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: [] +extra-deps: [ "fltkhs-0.4.0.9"] # Override default flag values for local packages and extra-deps flags: {} @@ -63,4 +63,4 @@ extra-package-dbs: [] # extra-lib-dirs: [/path/to/dir] # # Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file +# compiler-check: newer-minor