tests

src/Linux/TXML.hs

@@ -0,0 +1,43 @@
+
+module Linux.TXML
+  (
+    initialize
+  , uninitialize
+  , sendCommand
+  , setCallback
+  , freeCallback
+  , Callback
+  , LogLevel(..)
+  ) where
+
+import qualified Data.ByteString.Char8    as BS
+import qualified Data.Text                as T
+import           Data.Text.Encoding
+import           Data.Text.Encoding.Error
+import           Foreign.C.String
+import           Foreign.C.Types
+import           Foreign.Ptr
+
+data LogLevel =
+    Debug
+  | Info
+  | Warning
+  deriving (Show, Eq, Ord)
+
+newtype Callback = Callback { unCallback :: FunPtr (CString  -> IO CBool)}
+
+initialize :: FilePath -> LogLevel -> IO (Either T.Text ())
+initialize fp loglevel = return (Right ())
+
+uninitialize :: IO (Either T.Text ())
+uninitialize = return (Right ())
+
+sendCommand :: T.Text -> IO (Either T.Text ())
+sendCommand cmdData = return (Right ())
+
+setCallback :: (T.Text -> IO Bool) -> IO (Maybe Callback)
+setCallback callback = return Nothing
+
+freeCallback :: Callback -> IO ()
+freeCallback = freeHaskellFunPtr . unCallback
+

src/TXML.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 
 module TXML
   (
@@ -10,98 +11,8 @@ module TXML
   , LogLevel(..)
   ) where
 
-import qualified Data.ByteString.Char8    as BS
+#if defined(mingw32_HOST_OS)
-import qualified Data.Text                as T
+import           Win32.TXML
-import           Data.Text.Encoding
+#else
-import           Data.Text.Encoding.Error
+import           Linux.TXML
-import           Foreign.C.String
+#endif
-import           Foreign.C.Types
-import           Foreign.Ptr
-
-foreign import ccall "Initialize" c_Initialize :: CString -> CInt -> IO CString
-foreign import ccall "UnInitialize" c_UnInitialize :: IO CString
-foreign import ccall "SendCommand" c_SendCommand :: CString -> IO CString
-foreign import ccall "SetCallback" c_SetCallback ::
-  FunPtr (CString -> IO CBool) -> IO CBool
-foreign import ccall "FreeMemory" c_FreeMemory :: CString -> IO CBool
-
-{-
-foreign import ccall "SetLogLevel" c_SetLogLevel :: CInt -> IO CString
-foreign import ccall "SetCallbackEx" c_SetCallbackEx ::
-  FunPtr (CString -> CBool) -> Ptr () -> IO CBool
--}
-
-foreign import ccall "wrapper" createCallbackPtr ::
-  (CString -> IO CBool) -> IO (FunPtr (CString -> IO CBool))
-
-data LogLevel =
-    Debug
-  | Info
-  | Warning
-  deriving (Show, Eq, Ord)
-
-newtype Callback = Callback { unCallback :: FunPtr (CString  -> IO CBool)}
-
-logLevelToInt :: LogLevel -> CInt
-logLevelToInt Debug   = 3
-logLevelToInt Info    = 2
-logLevelToInt Warning = 1
-
-strErrorStringToResult :: CString -> IO (Either T.Text ())
-strErrorStringToResult str =
-  if nullPtr /= str
-    then do
-      packed <- BS.packCString str
-      let result = decodeUtf8With (replace '?') $ packed
-      _ <- c_FreeMemory str
-      pure $ Left result
-    else
-      pure $ Right ()
-
-rawStringToResult :: CString -> IO (Either T.Text ())
-rawStringToResult str =
-  if nullPtr /= str
-    then do
-      packed <- BS.packCString str
-      let result = decodeUtf8With (replace '?') $ packed
-      _ <- c_FreeMemory str
-      if "<result success=\"true\"/>" `T.isPrefixOf` result
-        then pure $ Right ()
-        else pure $ Left result
-    else
-      pure $ Left ""
-
-initialize :: FilePath -> LogLevel -> IO (Either T.Text ())
-initialize fp loglevel =
-  BS.useAsCString (encodeUtf8 . T.pack $ fp) $ \fpcstr ->
-    c_Initialize fpcstr (logLevelToInt loglevel) >>= strErrorStringToResult
-
-uninitialize :: IO (Either T.Text ())
-uninitialize = c_UnInitialize >>= rawStringToResult
-
-sendCommand :: T.Text -> IO (Either T.Text ())
-sendCommand cmdData = do
-  BS.useAsCString (encodeUtf8 cmdData) $ \fpcstr ->
-    c_SendCommand fpcstr >>= rawStringToResult
-
-setCallback :: (T.Text -> IO Bool) -> IO (Maybe Callback)
-setCallback callback = do
-  wrappedCallback <- createCallbackPtr (\x -> do
-                                           packed <- BS.packCString x
-                                           boolToCBool <$> (callback $
-                                             decodeUtf8With (replace '?')
-                                               packed))
-  ret <- c_SetCallback wrappedCallback
-  if ret /= 0
-    then return . Just . Callback $ wrappedCallback
-    else do
-      freeHaskellFunPtr wrappedCallback
-      return Nothing
-  where
-    boolToCBool False = 0
-    boolToCBool True  = 1
-
-freeCallback :: Callback -> IO ()
-freeCallback = freeHaskellFunPtr . unCallback
-
-

src/TXMLConnector.hs

@@ -46,6 +46,8 @@ import           Text.XML.Light.Input           (parseXML)
 import           Text.XML.Light.Types           (Content (Elem),
                                                  Element (elName),
                                                  QName (qName))
+import           TickTable                      (TickTable, insertTick,
+                                                 lookupTick, newTickTable)
 import           Transaq                        (AllTradesTrade (..),
                                                  Candle (..), ClientData (..),
                                                  CommandChangePass (..),
@@ -180,9 +182,6 @@ data MainQueueData =
   | MainQueueShutdown
   deriving (Eq, Show)
 
-data TickKey = TickKey TickerId DataType
-  deriving (Show, Ord, Eq)
-
 data TransactionId =
     TransactionId Int64
   | ExchangeOrderId Int64
@@ -206,7 +205,7 @@ data Env =
   , responseVar      :: TMVar (TMVar Response)
   , requestTimestamp :: TVar UTCTime
   , currentCandles   :: TVar [Candle]
-  , tickMap          :: TVar (M.Map TickKey Tick)
+  , tickMap          :: TickTable
   , transaqQueue     :: TBQueue TransaqResponse
   , logger           :: LogAction IO Message
   , config           :: TransaqConnectorConfig
@@ -233,7 +232,7 @@ start ::
 start logger config qssChannel tisH = do
   logWith logger Info "TXMLConnector" "Starting"
   notificationQueue <- atomically $ newTBQueue 50000
-  tickTable <- newTVarIO M.empty
+  tickTable <- newTickTable
   requestVar <- newEmptyTMVarIO
   responseVar <- newEmptyTMVarIO
   currentCandles <- newTVarIO []
@@ -640,7 +639,7 @@ workThread = do
           quotes = fmap subscriptionToSecurityId (quotesSubscriptions config)
         }
     subscriptionToSecurityId (SubscriptionConfig brd code) = SecurityId brd code
-    insertToTickMap tickMap tick = liftIO . atomically $ modifyTVar' tickMap (M.insert (TickKey (security tick) (datatype tick)) tick)
+    insertToTickMap tickMap tick = insertTick tickMap tick
 
 allTradeToTick :: AllTradesTrade -> Tick
 allTradeToTick att =

src/TickTable.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module TickTable
+  (
+    TickTable
+  , newTickTable
+  , insertTick
+  , lookupTick
+  ) where
+
+import           ATrade.Types                (DataType,
+                                              Tick (datatype, security),
+                                              TickerId)
+import           Control.Concurrent.STM.TVar (TVar, modifyTVar', newTVarIO,
+                                              readTVarIO)
+import           Control.Monad.IO.Class      (MonadIO (..))
+import           Control.Monad.STM           (atomically)
+import qualified Data.Map.Strict             as M
+
+data TickKey = TickKey TickerId DataType
+  deriving (Show, Ord, Eq)
+
+newtype TickTable =
+  TickTable
+  {
+    ttMap :: TVar (M.Map TickKey Tick)
+  }
+
+newTickTable :: (MonadIO m) => m TickTable
+newTickTable = do
+  ttMap <- liftIO $ newTVarIO M.empty
+  pure TickTable{..}
+
+insertTick :: (MonadIO m) => TickTable -> Tick -> m ()
+insertTick tickTable tick =
+    liftIO . atomically $ modifyTVar' (ttMap tickTable) (M.insert (TickKey (security tick) (datatype tick)) tick)
+
+lookupTick :: (MonadIO m) => TickTable -> TickerId -> DataType -> m (Maybe Tick)
+lookupTick tickTable tickerId datatype =
+  M.lookup (TickKey tickerId datatype) <$> liftIO (readTVarIO (ttMap tickTable))

src/Win32/TXML.hs

@@ -0,0 +1,100 @@
+
+module Win32.TXML
+  (
+    initialize
+  , uninitialize
+  , sendCommand
+  , setCallback
+  , freeCallback
+  , Callback
+  , LogLevel(..)
+  ) where
+
+import qualified Data.ByteString.Char8    as BS
+import qualified Data.Text                as T
+import           Data.Text.Encoding
+import           Data.Text.Encoding.Error
+import           Foreign.C.String
+import           Foreign.C.Types
+import           Foreign.Ptr
+
+foreign import ccall "Initialize" c_Initialize :: CString -> CInt -> IO CString
+foreign import ccall "UnInitialize" c_UnInitialize :: IO CString
+foreign import ccall "SendCommand" c_SendCommand :: CString -> IO CString
+foreign import ccall "SetCallback" c_SetCallback ::
+  FunPtr (CString -> IO CBool) -> IO CBool
+foreign import ccall "FreeMemory" c_FreeMemory :: CString -> IO CBool
+
+foreign import ccall "wrapper" createCallbackPtr ::
+  (CString -> IO CBool) -> IO (FunPtr (CString -> IO CBool))
+
+data LogLevel =
+    Debug
+  | Info
+  | Warning
+  deriving (Show, Eq, Ord)
+
+newtype Callback = Callback { unCallback :: FunPtr (CString  -> IO CBool)}
+
+logLevelToInt :: LogLevel -> CInt
+logLevelToInt Debug   = 3
+logLevelToInt Info    = 2
+logLevelToInt Warning = 1
+
+strErrorStringToResult :: CString -> IO (Either T.Text ())
+strErrorStringToResult str =
+  if nullPtr /= str
+    then do
+      packed <- BS.packCString str
+      let result = decodeUtf8With (replace '?') $ packed
+      _ <- c_FreeMemory str
+      pure $ Left result
+    else
+      pure $ Right ()
+
+rawStringToResult :: CString -> IO (Either T.Text ())
+rawStringToResult str =
+  if nullPtr /= str
+    then do
+      packed <- BS.packCString str
+      let result = decodeUtf8With (replace '?') $ packed
+      _ <- c_FreeMemory str
+      if "<result success=\"true\"/>" `T.isPrefixOf` result
+        then pure $ Right ()
+        else pure $ Left result
+    else
+      pure $ Left ""
+
+initialize :: FilePath -> LogLevel -> IO (Either T.Text ())
+initialize fp loglevel =
+  BS.useAsCString (encodeUtf8 . T.pack $ fp) $ \fpcstr ->
+    c_Initialize fpcstr (logLevelToInt loglevel) >>= strErrorStringToResult
+
+uninitialize :: IO (Either T.Text ())
+uninitialize = c_UnInitialize >>= rawStringToResult
+
+sendCommand :: T.Text -> IO (Either T.Text ())
+sendCommand cmdData = do
+  BS.useAsCString (encodeUtf8 cmdData) $ \fpcstr ->
+    c_SendCommand fpcstr >>= rawStringToResult
+
+setCallback :: (T.Text -> IO Bool) -> IO (Maybe Callback)
+setCallback callback = do
+  wrappedCallback <- createCallbackPtr (\x -> do
+                                           packed <- BS.packCString x
+                                           boolToCBool <$> (callback $
+                                             decodeUtf8With (replace '?')
+                                               packed))
+  ret <- c_SetCallback wrappedCallback
+  if ret /= 0
+    then return . Just . Callback $ wrappedCallback
+    else do
+      freeHaskellFunPtr wrappedCallback
+      return Nothing
+  where
+    boolToCBool False = 0
+    boolToCBool True  = 1
+
+freeCallback :: Callback -> IO ()
+freeCallback = freeHaskellFunPtr . unCallback
+

test/#Spec.hs#

@@ -0,0 +1,9 @@
+
+import           Test.Tasty
+
+main :: IO ()
+main = defaultMain $ testGroup "Tests" [unitTests]
+
+unitTests :: TestTree
+unitTests = testGroup "Unit Tests"
+  [ Test.RoboCom.Indicators.unitTests ]

test/Spec.hs

@@ -0,0 +1,10 @@
+import           Test.Tasty
+
+import qualified Test.TickTable
+
+main :: IO ()
+main = defaultMain $ testGroup "Tests" [unitTests]
+
+unitTests :: TestTree
+unitTests = testGroup "Unit Tests"
+  [Test.TickTable.unitTests ]

test/Test/TickTable.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.TickTable
+  (
+    unitTests
+  ) where
+
+import           ATrade.Price           (fromDouble)
+import           ATrade.Types           (DataType (..), Tick (..))
+import           Control.Monad.IO.Class (MonadIO (..))
+import           Data.Time              (fromGregorian)
+import           Data.Time.Clock        (UTCTime (..))
+import           Test.Tasty
+import           Test.Tasty.HUnit       (testCase, (@?=))
+import           TickTable              (insertTick, lookupTick, newTickTable)
+
+unitTests :: TestTree
+unitTests = testGroup "TickTable"
+  [ testInsertAndLookup ]
+
+testInsertAndLookup = testCase "Insert and lookup" $ do
+  tt <- liftIO newTickTable
+  insertTick tt testTick
+  maybeTick <- lookupTick tt (security testTick) (datatype testTick)
+  maybeTick @?= Just testTick
+  where
+    testTick = Tick
+      {
+        security = "TEST_TICK"
+      , datatype = LastTradePrice
+      , value = fromDouble 12.01
+      , volume = 45
+      , timestamp = UTCTime (fromGregorian 2000 1 1) 0
+      }

transaq-connector.cabal

@@ -17,14 +17,15 @@ extra-source-files:  README.md
 executable transaq-connector
   hs-source-dirs:      src
   main-is:             Main.hs
-  other-modules:       Config
+  other-modules:       Paths_transaq_connector
+                     , Config
                      , Transaq
                      , TickerInfoServer
                      , HistoryProviderServer
                      , Version
                      , TXML
                      , TXMLConnector 
-                     , Paths_transaq_connector
+                     , TickTable
   default-extensions:  OverloadedStrings
                      , MultiWayIf
   default-language:    Haskell2010
@@ -66,4 +67,19 @@ executable transaq-connector
                        -threaded -rtsopts -with-rtsopts=-N
   if os(windows)
     extra-libraries:     txmlconnector64
+    other-modules:       Win32.TXML
+  else
+    other-modules:       Linux.TXML
+
+test-suite transaq-connector-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test src
+  main-is:             Spec.hs
+  build-depends:       base
+                     , containers
+                     , libatrade
+                     , stm
+                     , tasty
+                     , tasty-hunit
+                     , time