diff --git a/src/Linux/TXML.hs b/src/Linux/TXML.hs new file mode 100644 index 0000000..e8f9455 --- /dev/null +++ b/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 + diff --git a/src/TXML.hs b/src/TXML.hs index 4952b9e..75a5036 100644 --- a/src/TXML.hs +++ b/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 -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 "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 "" `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 - - +#if defined(mingw32_HOST_OS) +import Win32.TXML +#else +import Linux.TXML +#endif diff --git a/src/TXMLConnector.hs b/src/TXMLConnector.hs index e731bdc..bb3dd1d 100644 --- a/src/TXMLConnector.hs +++ b/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 = diff --git a/src/TickTable.hs b/src/TickTable.hs new file mode 100644 index 0000000..10c02e7 --- /dev/null +++ b/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)) diff --git a/src/Win32/TXML.hs b/src/Win32/TXML.hs new file mode 100644 index 0000000..d9050d8 --- /dev/null +++ b/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 "" `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 + diff --git a/test/#Spec.hs# b/test/#Spec.hs# new file mode 100644 index 0000000..12529bd --- /dev/null +++ b/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 ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..d7aaee5 --- /dev/null +++ b/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 ] diff --git a/test/Test/TickTable.hs b/test/Test/TickTable.hs new file mode 100644 index 0000000..1766f22 --- /dev/null +++ b/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 + } diff --git a/transaq-connector.cabal b/transaq-connector.cabal index ea96684..bbdcd23 100644 --- a/transaq-connector.cabal +++ b/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