Dde Import Server initial implementation

.gitignore

@@ -0,0 +1 @@
+.*

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 ()
+

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
 

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)
+

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

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: {}