From cd37f6bf68bfcc4a0a88b281d34b117a63f14b4d Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 19 Mar 2023 10:43:04 +0700 Subject: [PATCH] Initial commit --- .gitignore | 2 + CHANGELOG.md | 11 + LICENSE | 30 ++ README.md | 1 + Setup.hs | 2 + src/ATrade/Quotes/QTIS.hs | 56 +++ src/Config.hs | 41 ++ src/Main.hs | 62 +++ src/TXML.hs | 107 +++++ src/TXMLConnector.hs | 308 +++++++++++++ src/TickTable.hs | 46 ++ src/Transaq.hs | 880 ++++++++++++++++++++++++++++++++++++++ src/Version.hs | 17 + stack.yaml | 79 ++++ stack.yaml.lock | 47 ++ transaq-connector.cabal | 62 +++ 16 files changed, 1751 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 src/ATrade/Quotes/QTIS.hs create mode 100644 src/Config.hs create mode 100644 src/Main.hs create mode 100644 src/TXML.hs create mode 100644 src/TXMLConnector.hs create mode 100644 src/TickTable.hs create mode 100644 src/Transaq.hs create mode 100644 src/Version.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 transaq-connector.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7a9a9e3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.* +lib \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..dfcbee2 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `transaq-connector` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5ef71ac --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..54b78d8 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# transaq-connector diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/ATrade/Quotes/QTIS.hs b/src/ATrade/Quotes/QTIS.hs new file mode 100644 index 0000000..3410e51 --- /dev/null +++ b/src/ATrade/Quotes/QTIS.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ATrade.Quotes.QTIS +( + TickerInfo(..), + qtisGetTickersInfo, + qtisGetTickersInfo' +) where + +import ATrade.Types +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Lazy as BL +import Data.Maybe +import qualified Data.Text as T +import System.ZMQ4 + +data TickerInfo = TickerInfo { + tiTicker :: T.Text, + tiLotSize :: Integer, + tiTickSize :: Price +} deriving (Show, Eq) + +instance FromJSON TickerInfo where + parseJSON = withObject "object" (\obj -> + TickerInfo <$> + obj .: "ticker" <*> + obj .: "lot_size" <*> + obj .: "tick_size") + +instance ToJSON TickerInfo where + toJSON ti = object [ "ticker" .= tiTicker ti, + "lot_size" .= tiLotSize ti, + "tick_size" .= tiTickSize ti ] + +qtisGetTickersInfo' :: T.Text -> [TickerId] -> IO [TickerInfo] +qtisGetTickersInfo' endpoint tickers = withContext (\ctx -> qtisGetTickersInfo ctx endpoint tickers) + +qtisGetTickersInfo :: Context -> T.Text -> [TickerId] -> IO [TickerInfo] +qtisGetTickersInfo ctx endpoint tickers = + withSocket ctx Req (\sock -> do + connect sock $ T.unpack endpoint + catMaybes <$> forM tickers (\tickerId -> do + send sock [] $ BL.toStrict (tickerRequest tickerId) + response <- receiveMulti sock + let r = parseResponse response + return r)) + where + tickerRequest tickerId = encode $ object ["ticker" .= tickerId] + parseResponse :: [BC8.ByteString] -> Maybe TickerInfo + parseResponse (header:payload:_) = if header == "OK" + then decode $ BL.fromStrict payload + else Nothing + parseResponse _ = Nothing + diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..917ac42 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Config + ( + TransaqConnectorConfig(..), + SubscriptionConfig(..), + loadConfig, + ) where + +import qualified Data.Text as T +import Dhall (FromDhall (autoWith), auto, expected, inputFile) +import GHC.Generics + +data SubscriptionConfig = SubscriptionConfig T.Text T.Text + deriving (Show, Eq, Ord, Generic) + +instance FromDhall SubscriptionConfig + +data TransaqConnectorConfig = TransaqConnectorConfig { + quotesourceEndpoint :: T.Text, + brokerEndpoint :: T.Text, + brokerNotificationsEndpoint :: T.Text, + brokerServerCertPath :: Maybe FilePath, + brokerClientCertificateDir :: Maybe FilePath, + tisEndpoint :: T.Text, + transaqLogin :: T.Text, + transaqPassword :: T.Text, + transaqHost :: T.Text, + transaqPort :: Int, + transaqLogPath :: FilePath, + transaqLogLevel :: Int, + tradesinks :: [T.Text], + allTradesSubscriptions :: [SubscriptionConfig], + quotationsSubscriptions :: [SubscriptionConfig], + quotesSubscriptions :: [SubscriptionConfig] + } deriving (Show, Eq, Generic) + +instance FromDhall TransaqConnectorConfig + +loadConfig :: FilePath -> IO TransaqConnectorConfig +loadConfig = inputFile auto diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..8215da3 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,62 @@ + +module Main (main) where + +import ATrade (libatrade_gitrev, + libatrade_version) +import ATrade.Logging (Message (..), Severity (Info), + logWith) +import ATrade.Logging (fmtMessage) +import ATrade.QuoteSource.Server (startQuoteSourceServer, + stopQuoteSourceServer) +import ATrade.Types (defaultServerSecurityParams) +import Colog (LogAction, logTextStdout, + (>$<)) +import Colog.Actions (logTextHandle) +import Config (TransaqConnectorConfig (..), + loadConfig) +import Control.Concurrent (threadDelay) +import Control.Concurrent.BoundedChan (newBoundedChan) +import Control.Exception (bracket) +import Control.Monad (forever, void) +import Control.Monad.IO.Class (MonadIO) +import qualified Data.Text as T +import Data.Version (showVersion) +import Debug.EventCounters (initEventCounters) +import Prelude hiding (log) +import System.IO (Handle, IOMode (AppendMode), + withFile) +import System.ZMQ4 (withContext) +import TickTable (mkTickTable) +import qualified TXMLConnector as Connector +import Version (transaqConnectorVersionText) + +mkLogger :: (MonadIO m) => Handle -> LogAction m Message +mkLogger h = fmtMessage >$< (logTextStdout <> logTextHandle h) + +main :: IO () +main = do + initEventCounters + cfg <- loadConfig "transaq-connector.dhall" + withFile "transaq-connector.log" AppendMode $ \logH -> do + let logger = mkLogger logH + let log = logWith logger + log Info "main" $ "Starting transaq-connector-" <> + transaqConnectorVersionText <> + "; libatrade-" <> + (T.pack . showVersion) libatrade_version <> + "(" <> + T.pack libatrade_gitrev <> + ")" + void $ withContext $ \ctx -> do + qssChannel <- newBoundedChan 50000 + bracket (startQuoteSourceServer + qssChannel + ctx + (quotesourceEndpoint cfg) + defaultServerSecurityParams) + stopQuoteSourceServer $ \_ -> do + _ <- Connector.start logger cfg qssChannel + forever $ threadDelay 1000000 + log Info "main" "Shutting down" + + diff --git a/src/TXML.hs b/src/TXML.hs new file mode 100644 index 0000000..4d43c82 --- /dev/null +++ b/src/TXML.hs @@ -0,0 +1,107 @@ + +module 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 "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 lenientDecode $ 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 lenientDecode $ 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 lenientDecode + 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/src/TXMLConnector.hs b/src/TXMLConnector.hs new file mode 100644 index 0000000..16f23bc --- /dev/null +++ b/src/TXMLConnector.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module TXMLConnector +( + start + ) where + +import ATrade.Logging (Message, Severity (..), + logWith) +import Colog (LogAction) +import Config (SubscriptionConfig (SubscriptionConfig), + TransaqConnectorConfig (..), + transaqHost, transaqLogLevel, + transaqLogPath, transaqLogin, + transaqPassword, transaqPort) +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Concurrent.STM (TVar, atomically, modifyTVar', + newTVarIO, readTVarIO, + writeTVar) +import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueue, + readTBQueue, writeTBQueue) +import Control.Monad (forever, void) +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Text.XML.Light.Input (parseXML) +import Text.XML.Light.Types (Content (Elem), + Element (elName), + QName (qName)) +import Transaq (AllTradesTrade (..), + CommandConnect (..), + CommandDisconnect (CommandDisconnect), + CommandSubscribe (..), + ConnectionState (Disconnected), + Language (LanguageEn), + MarketInfo (..), + Quotation (..), + ResponseAllTrades (ResponseAllTrades), + ResponseCandleKinds (ResponseCandleKinds), + ResponseMarkets (ResponseMarkets), + ResponseQuotations (ResponseQuotations), + ResponseQuotes (ResponseQuotes), + ResponseSecurities (ResponseSecurities), + SecurityId (..), + TransaqCommand (toXml), + TransaqResponse (..), + TransaqResponse (..), + TransaqResponseC (fromXml), + state) +import TXML (LogLevel, freeCallback, + initialize, sendCommand, + setCallback) + +import ATrade.QuoteSource.Server (QuoteSourceServerData (..)) +import ATrade.Types (DataType (BestBid, BestOffer, LastTradePrice), + Tick (..), TickerId, + fromDouble) +import Control.Concurrent.BoundedChan (BoundedChan, writeChan) +import Control.Monad (forM_) +import qualified Data.Map.Strict as M +import Data.Time.Clock (UTCTime, getCurrentTime) +import qualified Transaq +import qualified TXML + +data ConnectionParams = + ConnectionParams + { + cpLogin :: T.Text + , cpPassword :: T.Text + , cpHost :: T.Text + , cpPort :: Int + , cpLogPath :: T.Text + , cpLogLevel :: LogLevel + } + deriving (Show, Eq, Ord) + +data TXMLConnectorHandle = + TXMLConnectorHandle + { + threadId :: ThreadId, + notificationQueue :: TBQueue TransaqResponse + } + +data ConnectionStage = StageConnection | StageGetInfo | StageConnected + deriving (Eq, Show, Ord) + +data TickKey = TickKey TickerId DataType + deriving (Show, Ord, Eq) + +start :: + LogAction IO Message + -> TransaqConnectorConfig + -> BoundedChan QuoteSourceServerData + -> IO TXMLConnectorHandle +start logger config qssChannel = do + logWith logger Info "TXMLConnector" "Starting" + notificationQueue <- atomically $ newTBQueue 50000 + tickTable <- newTVarIO M.empty + threadId <- forkIO (workThread logger config notificationQueue qssChannel tickTable) + return $ TXMLConnectorHandle {..} + +workThread :: + LogAction IO Message + -> TransaqConnectorConfig + -> TBQueue TransaqResponse + -> BoundedChan QuoteSourceServerData + -> TVar (M.Map TickKey Tick) + -> IO () +workThread logger config queue qssChannel tickMap = do + rc <- initialize (transaqLogPath config) (parseTransaqLogLevel $ transaqLogLevel config) + case rc of + Left str -> log Error "TXMLConnector.WorkThread" $ "Unable to initialize TXML" <> str + Right _ -> do + rc <- setCallback parseAndWrite + case rc of + Nothing -> log Error "TXMLConnector.WorkThread" "Unable to set callback" + Just cb -> do + serverConnected <- newTVarIO StageConnection + void $ forever $ do + connStatus <- readTVarIO serverConnected + case connStatus of + StageConnection -> handleUnconnected serverConnected + StageGetInfo -> handleGetInfo serverConnected + StageConnected -> handleConnected serverConnected + freeCallback cb + where + log = logWith logger + parseTransaqLogLevel 1 = TXML.Warning + parseTransaqLogLevel 3 = TXML.Debug + parseTransaqLogLevel _ = TXML.Info + parseAndWrite xml = do + let parsed = mapMaybe parseContent $ parseXML xml + log Debug "TXML.Callback" $ "Parsed entities: " <> (T.pack . show . length) parsed + log Debug "TXML.Callback" $ "parsed xml: " <> (T.pack . show) (parseXML xml) + log Debug "TXML.Callback" $ "parsed: " <> (T.pack . show) xml + mapM_ writeToQueue parsed + pure True + parseContent (Elem el) = parseElement el + parseContent _ = Nothing + parseElement el = case qName $ elName el of + "candles" -> TransaqResponseCandles <$> fromXml el + "server_status" -> TransaqResponseServerStatus <$> fromXml el + "markets" -> TransaqResponseMarkets <$> fromXml el + "candlekinds" -> TransaqResponseCandleKinds <$> fromXml el + "securities" -> TransaqResponseSecurities <$> fromXml el + "sec_info" -> TransaqResponseSecInfo <$> fromXml el + "quotations" -> TransaqResponseQuotations <$> fromXml el + "alltrades" -> TransaqResponseAllTrades <$> fromXml el + "quotes" -> TransaqResponseQuotes <$> fromXml el + _ -> Nothing + writeToQueue resp = atomically $ writeTBQueue queue resp + handleConnected serverConnected = do + item <- atomically $ readTBQueue queue + case item of + TransaqResponseAllTrades (ResponseAllTrades trades) -> do + let ticks = fmap allTradeToTick trades + forM_ ticks (writeChan qssChannel . QSSTick) + forM_ ticks insertToTickMap + TransaqResponseQuotations (ResponseQuotations quotations) -> do + now <- getCurrentTime + let ticks = concatMap (quotationToTicks now) quotations + forM_ ticks (writeChan qssChannel . QSSTick) + forM_ ticks insertToTickMap + _ -> pure () + handleGetInfo serverConnected = do + item <- atomically $ readTBQueue queue + case item of + TransaqResponseServerStatus serverStatus -> + case state serverStatus of + Transaq.Disconnected -> do + log Warning "TXMLConnector.WorkThread" "Server disconnected" + atomically $ writeTVar serverConnected StageConnection + Transaq.Connected -> do + log Info "TXMLConnector.WorkThread" "Server connected" + atomically $ writeTVar serverConnected StageConnected + v <- makeSubscriptions config + case v of + Left errmsg -> do + log Warning "TXMLConnector.WorkThread" $ "Unable to subscribe: " <> errmsg + void $ sendCommand $ toXml CommandDisconnect + Right _ -> log Info "TXMLConnector.WorkThread" "Subscriptions done" + Transaq.Error errmsg -> do + log Warning "TXMLConnector.WorkThread" $ "Connection error: " <> errmsg + atomically $ writeTVar serverConnected StageConnection + TransaqResponseResult result -> + log Info "TXMLConnector.WorkThread" $ "Incoming result" <> (T.pack . show) result + -- TODO: handle order response + TransaqResponseCandles candles -> + log Debug "TXMLConnector.WorkThread" $ + "Incoming candles message: " <> (T.pack . show . length . Transaq.candles $ candles) + -- TODO: Pass to qhp + TransaqResponseMarkets (ResponseMarkets markets) -> do + log Debug "TXMLConnector.WorkThread" "Incoming markets:" + forM_ markets (\m -> log Debug "TXMLConnector.WorkThread" $ (T.pack . show) (marketId m) <> "/" <> marketName m) + -- TODO: Pass to qtis + TransaqResponseCandleKinds (ResponseCandleKinds kinds) -> do + log Debug "TXMLConnector.WorkThread" "Incoming candle kinds:" + forM_ kinds (log Debug "TXMLConnector.WorkThread" . (T.pack . show)) + -- TODO: Pass to qtis, maybe something else? + TransaqResponseSecurities (ResponseSecurities securities) -> do + log Debug "TXMLConnector.WorkThread" "Incoming securities:" + forM_ securities (log Debug "TXMLConnector.WorkThread" . (T.pack . show)) + -- TODO: Pass to qtis + TransaqResponseSecInfo secInfo -> + log Debug "TXMLConnector.WorkThread" $ "Incoming secinfo:" <> (T.pack . show) secInfo + -- TODO: Pass to qtis + TransaqResponseQuotations (ResponseQuotations quotations) -> do + log Debug "TXMLConnector.WorkThread" "Incoming quotations:" + forM_ quotations (log Debug "TXMLConnector.WorkThread" . (T.pack . show)) + -- Pass to ticktable and quotesource server + TransaqResponseQuotes (ResponseQuotes quotes) -> do + log Debug "TXMLConnector.WorkThread" "Incoming quotes:" + forM_ quotes (log Debug "TXMLConnector.WorkThread" . (T.pack . show)) + -- Pass to quotesource server + _ -> pure () + handleUnconnected serverConnected = do + log Debug "TXMLConnector.WorkThread" "Sending connect command" + v <- sendCommand $ + toXml $ CommandConnect + { + login = transaqLogin config, + password = transaqPassword config, + host = transaqHost config, + port = transaqPort config, + language = LanguageEn, + autopos = False, + micexRegisters = True, + milliseconds = True, + utcTime = True, + proxy = (), + rqDelay = Nothing, + sessionTimeout = Nothing, + requestTimeout = Nothing, + pushULimits = Nothing, + pushPosEquity = Nothing + } + case v of + Left err -> do + log Warning "TXMLConnector.WorkThread" $ "Unable to connect: [" <> err <> "]" + threadDelay (1000 * 1000 * 10) + Right _ -> do + atomically $ writeTVar serverConnected StageGetInfo + -- item <- atomically $ readTBQueue queue + -- case item of + -- TransaqResponseServerStatus status -> do + -- case state status of + -- Transaq.Error errmsg -> do + -- log Warning "TXMLConnector.WorkThread" $ "Unable to connect: " <> errmsg + -- void $ sendCommand $ toXml CommandDisconnect + -- threadDelay (10 * 1000 * 1000) + -- Transaq.Connected -> do + -- atomically $ writeTVar serverConnected StageGetInfo + -- -- v <- makeSubscriptions config + -- -- case v of + -- -- Left errmsg -> do + -- -- log Warning "TXMLConnector.WorkThread" $ "Unable to subscribe: " <> errmsg + -- -- void $ sendCommand $ toXml CommandDisconnect + -- -- Right _ -> + -- Transaq.Disconnected -> do + -- log Warning "TXMLConnector.WorkThread" "Unable to connect (disconnected)" + -- threadDelay (10 * 1000 * 1000) + -- other -> do + -- log Warning "TXMLConnector.WorkThread" $ "Stray message: " <> (T.pack . show) other + -- threadDelay (1000 * 1000) + makeSubscriptions config = + sendCommand $ toXml $ + CommandSubscribe + { + alltrades = fmap subscriptionToSecurityId (allTradesSubscriptions config), + quotations = fmap subscriptionToSecurityId (quotationsSubscriptions config), + quotes = fmap subscriptionToSecurityId (quotesSubscriptions config) + } + subscriptionToSecurityId (SubscriptionConfig brd code) = SecurityId brd code + insertToTickMap tick = atomically $ modifyTVar' tickMap (M.insert (TickKey (security tick) (datatype tick)) tick) + +allTradeToTick :: AllTradesTrade -> Tick +allTradeToTick att = + Tick + { + security = attBoard att <> "#" <> attSecCode att, + datatype = LastTradePrice, + timestamp = attTimestamp att, + value = fromDouble $ attPrice att, + volume = fromIntegral $ attQuantity att + } + +quotationToTicks :: UTCTime -> Quotation -> [Tick] +quotationToTicks timestamp q = + let security = qBoard q <> "#" <> qSeccode q in + [ + Tick + { + security = security, + datatype = BestBid, + timestamp = timestamp, + value = fromDouble $ qBid q, + volume = fromIntegral $ qQuantity q + }, + Tick + { + security = security, + datatype = BestOffer, + timestamp = timestamp, + value = fromDouble $ qOffer q, + volume = fromIntegral $ qQuantity q + }] diff --git a/src/TickTable.hs b/src/TickTable.hs new file mode 100644 index 0000000..e3335cd --- /dev/null +++ b/src/TickTable.hs @@ -0,0 +1,46 @@ + +module TickTable ( + mkTickTable, + TickKey(..), + getTick, + TickTableH +) where + +import ATrade.Types (DataType (..), Tick (..), + TickerId (..)) +import Control.Concurrent (forkIO) +import Control.Concurrent.BoundedChan (BoundedChan, readChan) +import Control.Concurrent.MVar (newEmptyMVar) +import Control.Concurrent.MVar (readMVar) +import Control.Concurrent.STM (TVar, atomically, modifyTVar', + newTVarIO, readTVarIO) +import Control.Monad (forever, void) +import Control.Monad.Extra (whileM) +import Data.IORef (readIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import System.ZMQ4 (Context) + +data TickKey = TickKey TickerId DataType + deriving (Show, Ord, Eq) + +data TickTable = TickTable { + ticks :: !(M.Map TickKey Tick) +} +type TickTableH = TVar TickTable + +mkTickTable :: BoundedChan Tick -> IO (TVar TickTable) +mkTickTable chan = do + shutdownMVar <- newEmptyMVar + r <- newTVarIO TickTable { ticks = M.empty } + void $ forkIO $ tickTableThread r shutdownMVar + return r + where + tickTableThread r shutdownMVar = whileM $ do + t <- readChan chan + atomically $ modifyTVar' r (\s -> s { ticks = M.insert (TickKey (security t) (datatype t)) t $! ticks s }) + readMVar shutdownMVar + +getTick :: TickTableH -> TickKey -> IO (Maybe Tick) +getTick r key = M.lookup key . ticks <$> readTVarIO r + diff --git a/src/Transaq.hs b/src/Transaq.hs new file mode 100644 index 0000000..7de1938 --- /dev/null +++ b/src/Transaq.hs @@ -0,0 +1,880 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} + +module Transaq + ( + CommandConnect(..), + Language(..), + TransaqCommand(..), + TransaqResponseC(..), + TransaqResponse(..), + SecurityId(..), + CommandDisconnect(..), + CommandSubscribe(..), + CommandNewOrder(..), + CommandCancelOrder(..), + CommandGetSecuritiesInfo(..), + ResponseResult(..), + ResponseCandles(..), + ResponseServerStatus(..), + ResponseCandleKinds(..), + ResponseMarkets(..), + ResponseSecurities(..), + ResponseSecInfo(..), + ResponseQuotations(..), + ResponseAllTrades(..), + ResponseTrades(..), + ResponseQuotes(..), + Quotation(..), + Quote(..), + TradeNotification(..), + OrderNotification(..), + AllTradesTrade(..), + Tick(..), + ConnectionState(..), + MarketInfo(..) + ) where + +import Control.Applicative ((<|>)) +import Control.Error.Util (hush) +import Control.Monad (void) +import Data.Attoparsec.Text (Parser, char, decimal, many', + maybeResult, parse, parseOnly, + skipSpace) +import Data.Decimal (DecimalRaw (..)) +import Data.Int (Int64) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, + maybeToList) +import qualified Data.Text as T +import Data.Time (fromGregorian) +import Data.Time.Clock (UTCTime (UTCTime)) +import Debug.Trace +import Text.Read (readMaybe) +import Text.XML.Light (Attr (..), CData (cdData), + Element (elName), Node (..), QName (..), + elChildren, findAttr, findChild, + onlyText, strContent, unode) +import Text.XML.Light.Output (showElement) +import Text.XML.Light.Types (Element (elContent), blank_name) + +data Language = LanguageRu | LanguageEn + deriving (Show, Eq, Ord) + +instance Node Language where + node n LanguageRu = node n ("ru" :: String) + node n LanguageEn = node n ("en" :: String) + +type TransaqPrice = DecimalRaw Int + +strAttr :: String -> String -> Attr +strAttr key val = Attr { attrKey = blank_name { qName = key}, attrVal = val} + +fromBool :: Bool -> String +fromBool True = "true" +fromBool False = "false" + +parseTimestamp :: T.Text -> Maybe UTCTime +parseTimestamp = hush . parseOnly parser + where + parser = parseWithDate <|> (UTCTime epoch <$> parseTime) + parseWithDate = do + date <- parseDate + skipSpace + time <- parseTime + pure $ UTCTime date time + parseDate = do + day <- decimal + void $ char '.' + month <- decimal + void $ char '.' + year <- decimal + pure $ fromGregorian year month day + + parseTime = do + hour <- (decimal :: Parser Int) + void $ char ':' + minute <- decimal + void $ char ':' + second <- decimal + msecs <- many' $ do + void $ char '.' + (decimal :: Parser Int) + let secofday = hour * 3600 + minute * 60 + second + case msecs of + [ms] -> pure $ fromIntegral secofday + fromIntegral ms / 1000.0 + _ -> pure $ fromIntegral secofday + epoch = fromGregorian 1970 1 1 + + +class TransaqCommand t where + toXml :: t -> T.Text + +class TransaqResponseC t where + fromXml :: Element -> Maybe t + +data CommandConnect = + CommandConnect + { + login :: T.Text, + password :: T.Text, + host :: T.Text, + port :: Int, + language :: Language, + autopos :: Bool, + micexRegisters :: Bool, + milliseconds :: Bool, + utcTime :: Bool, + proxy :: (), -- not supported + rqDelay :: Maybe Int, + sessionTimeout :: Maybe Int, + requestTimeout :: Maybe Int, + pushULimits :: Maybe Int, + pushPosEquity :: Maybe Int + } deriving (Show, Eq, Ord) + +instance Node CommandConnect where + node n CommandConnect {..} = node n (attrs, subnodes) + where + attrs = [strAttr "id" "connect"] + subnodes = + [ unode "login" (T.unpack login) + , unode "password" (T.unpack password) + , unode "host" (T.unpack host) + , unode "port" (show port) + , unode "language" language + , unode "autopos" (fromBool autopos) + , unode "micex_registers" (fromBool micexRegisters) + , unode "milliseconds" (fromBool milliseconds) + , unode "utc_time" (fromBool utcTime) + ] + ++ maybeToList (unode "rqdelay" . show <$> rqDelay) + ++ maybeToList (unode "session_timeout" . show <$> sessionTimeout) + ++ maybeToList (unode "request_timeout" . show <$> requestTimeout) + ++ maybeToList (unode "push_u_limits" . show <$> pushULimits) + ++ maybeToList (unode "push_pos_limits" . show <$> pushPosEquity) + +instance TransaqCommand CommandConnect where + toXml = T.pack . showElement . unode "command" + +data CommandDisconnect = CommandDisconnect + deriving (Show, Eq, Ord) + +instance TransaqCommand CommandDisconnect where + toXml CommandDisconnect = T.pack . showElement $ unode "command" [strAttr "id" "disconnect"] + +data SecurityId = + SecurityId + { + board :: T.Text + , seccode :: T.Text + } deriving (Show, Eq, Ord) + +instance Node SecurityId where + node n SecurityId {..} = node n + [ unode "board" (T.unpack board) + , unode "seccode" (T.unpack seccode) + ] + +data CommandSubscribe = + CommandSubscribe + { + alltrades :: [SecurityId] + , quotations :: [SecurityId] + , quotes :: [SecurityId] + } deriving (Show, Eq, Ord) + +instance TransaqCommand CommandSubscribe where + toXml CommandSubscribe {..} = + T.pack . showElement $ unode "command" ([strAttr "id" "subscribe"], + [ unode "alltrades" $ fmap (unode "security") alltrades + , unode "quotations" $ fmap (unode "security") quotations + , unode "quotes" $ fmap (unode "security") quotes + ]) + +data CommandUnsubscribe = + CommandUnsubscribe + { + alltrades :: [SecurityId] + , quotations :: [SecurityId] + , quotes :: [SecurityId] + } deriving (Show, Eq, Ord) + +instance TransaqCommand CommandUnsubscribe where + toXml CommandUnsubscribe {..} = + T.pack . showElement $ unode "command" ([strAttr "id" "unsubscribe"], + [ unode "alltrades" $ fmap (unode "security") alltrades + , unode "quotations" $ fmap (unode "security") quotations + , unode "quotes" $ fmap (unode "security") quotes + ]) + +data CommandGetHistoryData = + CommandGetHistoryData + { + security :: SecurityId + , periodId :: Int + , count :: Int + , reset :: Bool + } deriving (Show, Eq, Ord) + +instance TransaqCommand CommandGetHistoryData where + toXml CommandGetHistoryData {..} = + T.pack . showElement $ unode "command" ([strAttr "id" "gethistorydata"], + [ unode "security" security + , unode "period" (show periodId) + , unode "count" (show count) + , unode "reset" (fromBool reset) + ]) + +data TradeDirection = Buy | Sell + deriving (Show, Eq, Ord) + +instance Node TradeDirection where + node n Buy = node n ("B" :: String) + node n Sell = node n ("S" :: String) + +data UnfilledAction = + UnfilledPutInQueue + | UnfilledFOK + | UnfilledIOC + deriving (Show, Eq, Ord) + +instance Node UnfilledAction where + node n UnfilledPutInQueue = node n ("PutInQueue" :: String) + node n UnfilledFOK = node n ("FOK" :: String) + node n UnfilledIOC = node n ("IOC" :: String) + +data CommandNewOrder = + CommandNewOrder + { + security :: SecurityId + , client :: T.Text + , unionCode :: T.Text + , price :: TransaqPrice + , quantity :: Int + , buysell :: TradeDirection + , bymarket :: Bool + , brokerRef :: T.Text + , unfilled :: UnfilledAction + , usecredit :: Bool + , nosplit :: Bool + } deriving (Show, Eq, Ord) + +instance TransaqCommand CommandNewOrder where + toXml CommandNewOrder {..} = + T.pack . showElement $ unode "command" ([strAttr "id" "neworder"], + [ unode "security" security + , unode "client" $ T.unpack client + , unode "union" $ T.unpack unionCode + , unode "price" $ show price + , unode "quantity" $ show quantity + , unode "buysell" buysell + , unode "brokerref" $ T.unpack brokerRef + , unode "unfillled" unfilled + ] + ++ boolToList "bymarket" bymarket + ++ boolToList "usecredit" usecredit + ++ boolToList "nosplit" nosplit) + where + boolToList n True = [unode n ("" :: String)] + boolToList _ False = [] + +newtype CommandCancelOrder = + CommandCancelOrder + { + transactionId :: Integer + } deriving (Show, Eq, Ord) + +instance TransaqCommand CommandCancelOrder where + toXml CommandCancelOrder{..} = + T.pack . showElement $ unode "command" ([strAttr "id" "cancelOrder"], + [ unode "transactionid" (show transactionId)]) + +newtype CommandGetSecuritiesInfo = + CommandGetSecuritiesInfo + { + securities :: [SecurityId] + } deriving (Show, Eq, Ord) + +instance TransaqCommand CommandGetSecuritiesInfo where + toXml CommandGetSecuritiesInfo{..} = + T.pack . showElement $ unode "command" ([strAttr "id" "get_securities_info"], + fmap (unode "security") securities) + +data ResponseResult = + ResponseSuccess + | ResponseFailure T.Text + deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseResult where + fromXml root = + if qName (elName root) == "result" + then + if findAttr (blank_name {qName = "success"}) root == Just "true" + then Just ResponseSuccess + else Just . ResponseFailure . T.pack . concatMap cdData . onlyText . elContent $ root + else Nothing + + +data Candle = + Candle + { + cTimestamp :: UTCTime + , cOpen :: TransaqPrice + , cHigh :: TransaqPrice + , cLow :: TransaqPrice + , cClose :: TransaqPrice + , cVolume :: Int + , cOpenInterest :: Int + } deriving (Show, Eq, Ord) + +data ResponseCandlesStatus = + StatusEndOfHistory + | StatusDone + | StatusPending + | StatusUnavaliable + deriving (Show, Eq, Ord) + +data ResponseCandles = + ResponseCandles + { + periodId :: Int + , status :: ResponseCandlesStatus + , security :: SecurityId + , candles :: [Candle] + } deriving (Show, Eq, Ord) + +uname :: String -> QName +uname x = blank_name {qName = x} + +childContent :: String -> Element -> Maybe String +childContent tag el = strContent <$> findChild (uname tag) el + +instance TransaqResponseC ResponseCandles where + fromXml root = do + periodId <- findAttr (uname "period") root >>= readMaybe + status <- findAttr (uname "status") root >>= readMaybe >>= parseStatus + board <- T.pack <$> findAttr (uname "board") root + seccode <- T.pack <$> findAttr (uname "seccode") root + let candles = mapMaybe parseCandle . elChildren $ root + return ResponseCandles + { + periodId = periodId + , status = status + , security = SecurityId board seccode + , candles = candles + } + where + parseStatus :: Int -> Maybe ResponseCandlesStatus + parseStatus intStatus = + case intStatus of + 0 -> Just StatusEndOfHistory + 1 -> Just StatusDone + 2 -> Just StatusPending + 3 -> Just StatusUnavaliable + _ -> Nothing + parseCandle element = do + timestamp <- findAttr (uname "open") element >>= parseTimestamp . T.pack + open <- findAttr (uname "open") element >>= readMaybe + high <- findAttr (uname "high") element >>= readMaybe + low <- findAttr (uname "low") element >>= readMaybe + close <- findAttr (uname "close") element >>= readMaybe + volume <- findAttr (uname "volume") element >>= readMaybe + openInterest <- findAttr (uname "oi") element >>= readMaybe + return Candle + { + cTimestamp = timestamp + , cOpen = open + , cHigh = high + , cLow = low + , cClose = close + , cVolume = volume + , cOpenInterest = openInterest + } + +data ConnectionState = + Connected + | Disconnected + | Error T.Text + deriving (Show, Eq, Ord) + +data ResponseServerStatus = + ResponseServerStatus + { + serverId :: Maybe Int + , state :: ConnectionState + , recover :: Maybe Bool + , serverTimezone :: Maybe T.Text + , systemVersion :: Maybe Int + , build :: Maybe Int + } deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseServerStatus where + fromXml root = do + let serverId = findAttr (uname "id") root >>= readMaybe + connectedStr <- findAttr (uname "connected") root + state <- case connectedStr of + "true" -> pure Connected + "false" -> pure Disconnected + "error" -> pure $ Error (T.pack $ strContent root) + _ -> pure Disconnected + let recover = + case findAttr (uname "recover") root of + Just "true" -> pure True + _ -> pure False + let serverTimezone = T.pack <$> findAttr (uname "server_tz") root + let systemVersion = findAttr (uname "sys_ver") root >>= readMaybe + let build = findAttr (uname "build") root >>= readMaybe + pure $ ResponseServerStatus {..} + +data MarketInfo = + MarketInfo + { marketId :: Int + , marketName :: T.Text + } deriving (Show, Eq, Ord) + +newtype ResponseMarkets = ResponseMarkets [MarketInfo] + deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseMarkets where + fromXml root = do + markets <- mapM parseMarketInfo $ elChildren root + pure . ResponseMarkets . catMaybes $ markets + where + parseMarketInfo tag = + if (qName . elName) tag == "market" + then do + marketId <- findAttr (uname "id") tag >>= readMaybe + let marketName = T.pack $ strContent tag + pure $ Just $ MarketInfo {..} + else pure Nothing + +data CandleKind = + CandleKind + { + kCandleKindId :: Int + , kPeriod :: Int + , kName :: T.Text + } deriving (Show, Eq, Ord) + +newtype ResponseCandleKinds = ResponseCandleKinds [CandleKind] + deriving (Show, Eq, Ord) + + +instance TransaqResponseC ResponseCandleKinds where + fromXml root = do + kinds <- mapM parseCandleKind $ elChildren root + pure . ResponseCandleKinds . catMaybes $ kinds + where + parseCandleKind tag = + if (qName . elName) tag == "kind" + then do + kCandleKindId <- childContent "id" tag >>= readMaybe + kPeriod <- childContent "period" tag >>= readMaybe + kName <- T.pack <$> childContent "name" tag + pure . Just $ CandleKind {..} + else pure Nothing + +data Security = + Security + { + secId :: Int + , active :: Bool + , seccode :: T.Text + , instrClass :: T.Text + , board :: T.Text + , market :: T.Text + , currency :: T.Text + , shortName :: T.Text + , decimals :: Int + , minStep :: Double + , lotSize :: Int + , lotDivider :: Int + , pointCost :: Double + , secType :: T.Text + } deriving (Show, Eq, Ord) + +newtype ResponseSecurities = + ResponseSecurities [Security] + deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseSecurities where + fromXml root = do + securities <- mapM parseSecurity $ elChildren root + pure . ResponseSecurities . catMaybes $ securities + where + parseSecurity tag = + if (qName . elName) tag == "security" + then do + secId <- findAttr (uname "secid") tag >>= readMaybe + active <- findAttr (uname "active") tag >>= parseBool + seccode <- T.pack <$> childContent "seccode" tag + instrClass <- T.pack <$> childContent "instrclass" tag + board <- T.pack <$> childContent "instrclass" tag + market <- T.pack <$> childContent "market" tag + currency <- T.pack <$> childContent "currency" tag + shortName <- T.pack <$> childContent "shortname" tag + decimals <- childContent "decimals" tag >>= readMaybe + minStep <- childContent "minstep" tag >>= readMaybe + lotSize <- childContent "lotsize" tag >>= readMaybe + lotDivider <- childContent "lotdivider" tag >>= readMaybe + pointCost <- childContent "point_cost" tag >>= readMaybe + secType <- T.pack <$> childContent "sectype" tag + pure . Just $ Security {..} + else + pure Nothing + + parseBool "true" = Just True + parseBool "false" = Just False + parseBool _ = Nothing + + +data ResponseSecInfo = + ResponseSecInfo + { + secId :: Int + , secName :: T.Text + , secCode :: T.Text + , market :: Int + , pname :: T.Text + , clearingPrice :: Double + , minprice :: Double + , maxprice :: Double + , pointCost :: Double + } deriving (Show, Eq, Ord) + + +instance TransaqResponseC ResponseSecInfo where + fromXml tag = do + secId <- findAttr (uname "secid") tag >>= readMaybe + secName <- T.pack <$> childContent "secname" tag + secCode <- T.pack <$> childContent "seccode" tag + market <- childContent "market" tag >>= readMaybe + pname <- T.pack <$> childContent "pname" tag + clearingPrice <- childContent "clearing_price" tag >>= readMaybe + minprice <- childContent "minprice" tag >>= readMaybe + maxprice <- childContent "maxprice" tag >>= readMaybe + pointCost <- childContent "point_cost" tag >>= readMaybe + pure ResponseSecInfo {..} + +data Quotation = + Quotation + { + qSecId :: Int + , qBoard :: T.Text + , qSeccode :: T.Text + , qOpen :: Double + , qWaprice :: Double + , qBidDepth :: Int + , qBidDepthT :: Int + , qNumBids :: Int + , qOfferDepth :: Int + , qOfferDepthT :: Int + , qBid :: Double + , qOffer :: Double + , qNumOffers :: Int + , qNumTrades :: Int + , qVolToday :: Int + , qOpenPositions :: Int + , qLastPrice :: Double + , qQuantity :: Int + , qTimestamp :: UTCTime + , qValToday :: Double + } deriving (Show, Eq, Ord) + +newtype ResponseQuotations = + ResponseQuotations [Quotation] + deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseQuotations where + fromXml root = do + quotations <- mapM parseQuotation $ elChildren root + pure . ResponseQuotations . catMaybes $ quotations + where + parseQuotation tag = do + qSecId <- findAttr (uname "secid") tag >>= readMaybe + qBoard <- T.pack <$> childContent "board" tag + qSeccode <- T.pack <$> childContent "seccode" tag + qOpen <- childContent "open" tag >>= readMaybe + qWaprice <- childContent "waprice" tag >>= readMaybe + qBidDepth <- childContent "biddepth" tag >>= readMaybe + qBidDepthT <- childContent "biddeptht" tag >>= readMaybe + qNumBids <- childContent "numbids" tag >>= readMaybe + qBid <- childContent "bid" tag >>= readMaybe + qOfferDepth <- childContent "offerdepth" tag >>= readMaybe + qOfferDepthT <- childContent "offerdeptht" tag >>= readMaybe + qNumOffers <- childContent "numoffers" tag >>= readMaybe + qOffer <- childContent "offer" tag >>= readMaybe + qNumTrades <- childContent "numtrades" tag >>= readMaybe + qVolToday <- childContent "voltoday" tag >>= readMaybe + qOpenPositions <- childContent "openpositions" tag >>= readMaybe + qLastPrice <- childContent "last" tag >>= readMaybe + qQuantity <- childContent "quantity" tag >>= readMaybe + qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack) + qValToday <- childContent "valToday" tag >>= readMaybe + pure $ Just Quotation {..} + +data TradingPeriod = + PeriodOpen + | PeriodNormal + | PeriodClose + | PeriodUnknown + deriving (Show, Eq, Ord) + +data AllTradesTrade = + AllTradesTrade + { + attSecId :: Int + , attSecCode :: T.Text + , attTradeNo :: Int64 + , attTimestamp :: UTCTime + , attBoard :: T.Text + , attPrice :: Double + , attQuantity :: Int + , attBuysell :: TradeDirection + , attOpenInterest :: Int + , attPeriod :: TradingPeriod + } deriving (Show, Eq, Ord) + +newtype ResponseAllTrades = + ResponseAllTrades [AllTradesTrade] + deriving (Show, Eq, Ord) + +parseTradeDirection :: T.Text -> Maybe TradeDirection +parseTradeDirection t = + case t of + "B" -> Just Buy + "S" -> Just Sell + _ -> Nothing + +instance TransaqResponseC ResponseAllTrades where + fromXml root = do + alltrades <- mapM parseAllTrade $ elChildren root + pure . ResponseAllTrades . catMaybes $ alltrades + where + parseAllTrade tag = do + attSecId <- findAttr (uname "secid") tag >>= readMaybe + attSecCode <- T.pack <$> childContent "seccode" tag + attTradeNo <- childContent "tradeno" tag >>= readMaybe + attTimestamp <- T.pack <$> childContent "time" tag >>= parseTimestamp + attBoard <- T.pack <$> childContent "board" tag + attPrice <- childContent "price" tag >>= readMaybe + attQuantity <- childContent "quantity" tag >>= readMaybe + attBuysell <- T.pack <$> childContent "buysell" tag >>= parseTradeDirection + let attOpenInterest = fromMaybe 0 $ childContent "openinterest" tag >>= readMaybe + let attPeriod = fromMaybe PeriodUnknown $ childContent "period" tag >>= parseTradingPeriod + pure . Just $ AllTradesTrade {..} + + parseTradingPeriod :: String -> Maybe TradingPeriod + parseTradingPeriod "O" = Just PeriodOpen + parseTradingPeriod "N" = Just PeriodNormal + parseTradingPeriod "C" = Just PeriodClose + parseTradingPeriod _ = Nothing + + +data Quote = + Quote + { + secId :: Int + , board :: T.Text + , secCode :: T.Text + , price :: Double + , source :: T.Text + , yield :: Int + , buy :: Int + , sell :: Int + } deriving (Show, Eq, Ord) + +newtype ResponseQuotes = + ResponseQuotes [Quote] + deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseQuotes where + fromXml root = do + quotes <- mapM parseQuote $ elChildren root + pure . ResponseQuotes . catMaybes $ quotes + where + parseQuote tag = do + secId <- findAttr (uname "secid") tag >>= readMaybe + secCode <- T.pack <$> childContent "seccode" tag + board <- T.pack <$> childContent "board" tag + price <- childContent "price" tag >>= readMaybe + source <- T.pack <$> childContent "source" tag + yield <- childContent "yield" tag >>= readMaybe + buy <- childContent "buy" tag >>= readMaybe + sell <- childContent "sell" tag >>= readMaybe + return . Just $ Quote {..} + +data OrderStatus = + OrderCancelled + | OrderDenied + | OrderDisabled + | OrderExpired + | OrderFailed + | OrderLinkWait + | OrderRejected + | OrderSLExecuted + | OrderSLForwarding + | OrderSLGuardTime + | OrderTPCorrection + | OrderTPCorrectionGuardTime + | OrderTPExecuted + | OrderTPForwarding + | OrderTPGuardTime + | OrderWatching + deriving (Show, Eq, Ord) + +data OrderNotification = + OrderNotification + { + transactionId :: Int + , orderNo :: Int64 + , secId :: Int + , board :: T.Text + , secCode :: T.Text + , client :: T.Text + , union :: T.Text + , status :: OrderStatus + , buysell :: TradeDirection + , timestamp :: UTCTime + , brokerRef :: T.Text + , balance :: Int + , price :: Double + , quantity :: Int + , result :: T.Text + } deriving (Show, Eq, Ord) + +newtype ResponseOrders = + ResponseOrders [OrderNotification] + deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseOrders where + fromXml root = do + quotes <- mapM parseOrder $ elChildren root + pure . ResponseOrders . catMaybes $ quotes + where + parseOrder tag = do + transactionId <- findAttr (uname "transactionid") tag >>= readMaybe + orderNo <- childContent "orderno" tag >>= readMaybe + secId <- childContent "secid" tag >>= readMaybe + board <- T.pack <$> childContent "board" tag + secCode <- T.pack <$> childContent "seccode" tag + client <- T.pack <$> childContent "client" tag + union <- T.pack <$> childContent "union" tag + status <- childContent "status" tag >>= parseStatus + buysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack + timestamp <- childContent "time" tag >>= parseTimestamp . T.pack + brokerRef <- T.pack <$> childContent "brokerref" tag + balance <- childContent "balance" tag >>= readMaybe + price <- childContent "price" tag >>= readMaybe + quantity <- childContent "quantity" tag >>= readMaybe + result <- T.pack <$> childContent "result" tag + return . Just $ OrderNotification {..} + parseStatus "cancelled" = Just OrderCancelled + parseStatus "denied" = Just OrderDenied + parseStatus "disabled" = Just OrderDisabled + parseStatus "expired" = Just OrderExpired + parseStatus "failed" = Just OrderFailed + parseStatus "linkwait" = Just OrderLinkWait + parseStatus "rejected" = Just OrderRejected + parseStatus "sl_executed" = Just OrderSLExecuted + parseStatus "sl_forwarding" = Just OrderSLForwarding + parseStatus "sl_guardtime" = Just OrderSLGuardTime + parseStatus "tp_correction" = Just OrderTPCorrection + parseStatus "tp_correction_guardtime" = Just OrderTPCorrectionGuardTime + parseStatus "tp_executed" = Just OrderTPExecuted + parseStatus "tp_forwarding" = Just OrderTPForwarding + parseStatus "tp_guardtime" = Just OrderTPGuardTime + parseStatus "watching" = Just OrderWatching + parseStatus _ = Nothing + +data TradeNotification = + TradeNotification + { + secId :: Int + , tradeNo :: Int64 + , orderNo :: Int64 + , board :: T.Text + , secCode :: T.Text + , client :: T.Text + , union :: T.Text + , buysell :: TradeDirection + , timestamp :: UTCTime + , value :: Double + , comission :: Double + , price :: Double + } deriving (Show, Eq, Ord) + +newtype ResponseTrades = + ResponseTrades [TradeNotification] + deriving (Show, Eq, Ord) + +instance TransaqResponseC ResponseTrades where + fromXml root = do + quotes <- mapM parseTrade $ elChildren root + pure . ResponseTrades . catMaybes $ quotes + where + parseTrade tag = do + secId <- childContent "secid" tag >>= readMaybe + tradeNo <- childContent "tradeno" tag >>= readMaybe + orderNo <- childContent "orderno" tag >>= readMaybe + board <- T.pack <$> childContent "board" tag + secCode <- T.pack <$> childContent "seccode" tag + client <- T.pack <$> childContent "client" tag + union <- T.pack <$> childContent "union" tag + buysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack + timestamp <- childContent "time" tag >>= parseTimestamp . T.pack + value <- childContent "value" tag >>= readMaybe + comission <- childContent "comission" tag >>= readMaybe + price <- childContent "price" tag >>= readMaybe + pure . Just $ TradeNotification {..} + +data Tick = + Tick + { + secId :: Int + , tradeNo :: Int64 + , timestamp :: UTCTime + , price :: Double + , quantity :: Int + , period :: TradingPeriod + , buySell :: TradeDirection + , openInterest :: Int + , board :: T.Text + , secCode :: T.Text + } deriving (Show, Eq, Ord) + +newtype ResponseTicks = + ResponseTicks [Tick] + deriving (Show, Eq, Ord) + +data TransaqResponse = + TransaqResponseResult ResponseResult + | TransaqResponseCandles ResponseCandles + | TransaqResponseServerStatus ResponseServerStatus + | TransaqResponseMarkets ResponseMarkets + | TransaqResponseCandleKinds ResponseCandleKinds + | TransaqResponseSecurities ResponseSecurities + | TransaqResponseSecInfo ResponseSecInfo + | TransaqResponseQuotations ResponseQuotations + | TransaqResponseAllTrades ResponseAllTrades + | TransaqResponseQuotes ResponseQuotes + | TransaqResponseOrders ResponseOrders + | TransaqResponseTrades ResponseTrades + deriving (Show, Eq, Ord) + +instance TransaqResponseC TransaqResponse where + fromXml root = case qName . elName $ root of + "result" -> TransaqResponseResult <$> fromXml root + "error" -> TransaqResponseResult <$> fromXml root + "candles" -> TransaqResponseCandles <$> fromXml root + "server_status" -> TransaqResponseServerStatus <$> fromXml root + "markets" -> TransaqResponseMarkets <$> fromXml root + "candlekinds" -> TransaqResponseCandleKinds <$> fromXml root + "securities" -> TransaqResponseSecurities <$> fromXml root + "sec_info" -> TransaqResponseSecInfo <$> fromXml root + "quotations" -> TransaqResponseQuotations <$> fromXml root + "alltrades" -> TransaqResponseAllTrades <$> fromXml root + "quotes" -> TransaqResponseQuotes <$> fromXml root + "orders" -> TransaqResponseOrders <$> fromXml root + "trades" -> TransaqResponseTrades <$> fromXml root + _ -> Nothing diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 index 0000000..fc2ea7d --- /dev/null +++ b/src/Version.hs @@ -0,0 +1,17 @@ +module Version + ( + transaqConnectorVersion, + transaqConnectorVersionText + ) where + +import qualified Data.Text as T +import Data.Version +import Paths_transaq_connector + + +transaqConnectorVersion :: Version +transaqConnectorVersion = version + +transaqConnectorVersionText :: T.Text +transaqConnectorVersionText = T.pack $ showVersion version + diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..4af19e9 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,79 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-18.18 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +- ../libatrade +- ../zeromq4-haskell-zap +- ../eventcounters + +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +extra-deps: +- datetime-0.3.1 +- co-log-0.4.0.1@sha256:3d4c17f37693c80d1aa2c41669bc3438fac3e89dc5f479e57d79bc3ddc4dfcc5,5087 +- ansi-terminal-0.10.3@sha256:e2fbcef5f980dc234c7ad8e2fa433b0e8109132c9e643bc40ea5608cd5697797,3226 +- proto3-suite-0.5.1@sha256:045994919b105b89c44e3ae94f50258b86a6ebfd14425845e13e0921d2e8610e,7015 +- clock-0.8@sha256:b4ae207e2d3761450060a0d0feb873269233898039c76fceef9cc1a544067767,4113 + + +# Override default flag values for local packages and extra-deps +# flags: {} +flags: + mintty: + Win32-2-13-1: false + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..3fb5f55 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,47 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: datetime-0.3.1@sha256:7e275bd0ce7a2f66445bedfa0006abaf4d41af4c2204c3f8004c17eab5480e74,1534 + pantry-tree: + size: 334 + sha256: d41d182c143676464cb1774f0b7777e870ddeaf8b6cd5fee6ff0114997a1f504 + original: + hackage: datetime-0.3.1 +- completed: + hackage: co-log-0.4.0.1@sha256:3d4c17f37693c80d1aa2c41669bc3438fac3e89dc5f479e57d79bc3ddc4dfcc5,5087 + pantry-tree: + size: 1126 + sha256: e73165ff8f744709428e2e87984c9d60ca1cec43d8455c413181c7c466e7497c + original: + hackage: co-log-0.4.0.1@sha256:3d4c17f37693c80d1aa2c41669bc3438fac3e89dc5f479e57d79bc3ddc4dfcc5,5087 +- completed: + hackage: ansi-terminal-0.10.3@sha256:e2fbcef5f980dc234c7ad8e2fa433b0e8109132c9e643bc40ea5608cd5697797,3226 + pantry-tree: + size: 1461 + sha256: 02f05d52be3ffcf36c78876629cbab80b63420672685371aea4fd10e1c4aabb6 + original: + hackage: ansi-terminal-0.10.3@sha256:e2fbcef5f980dc234c7ad8e2fa433b0e8109132c9e643bc40ea5608cd5697797,3226 +- completed: + hackage: proto3-suite-0.5.1@sha256:045994919b105b89c44e3ae94f50258b86a6ebfd14425845e13e0921d2e8610e,7015 + pantry-tree: + size: 3402 + sha256: 7387c16e46bdcbcfdfc87b42a1dfd17bf6f7168a50b409469d993f7f73a6f133 + original: + hackage: proto3-suite-0.5.1@sha256:045994919b105b89c44e3ae94f50258b86a6ebfd14425845e13e0921d2e8610e,7015 +- completed: + hackage: clock-0.8@sha256:b4ae207e2d3761450060a0d0feb873269233898039c76fceef9cc1a544067767,4113 + pantry-tree: + size: 446 + sha256: d9ac8ce6a19812fe74cb1e74228e6e624eda19021ff4d12e24611f88abacd38a + original: + hackage: clock-0.8@sha256:b4ae207e2d3761450060a0d0feb873269233898039c76fceef9cc1a544067767,4113 +snapshots: +- completed: + size: 586296 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml + sha256: 63539429076b7ebbab6daa7656cfb079393bf644971156dc349d7c0453694ac2 + original: lts-18.18 diff --git a/transaq-connector.cabal b/transaq-connector.cabal new file mode 100644 index 0000000..3dffdb1 --- /dev/null +++ b/transaq-connector.cabal @@ -0,0 +1,62 @@ +name: transaq-connector +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/githubuser/transaq-connector#readme +license: BSD3 +license-file: LICENSE +author: Denis Tereshkin +maintainer: denis@kasan.ws +copyright: 2023 Denis Tereshkin +category: Web +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + CHANGELOG.md + +executable transaq-connector + hs-source-dirs: src + main-is: Main.hs + other-modules: Config + , TickTable + , Transaq + , Version + , TXML + , TXMLConnector + , Paths_transaq_connector + default-extensions: OverloadedStrings + , MultiWayIf + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , dhall + , eventcounters + , libatrade + , text + , transformers + , co-log + , zeromq4-haskell + , aeson + , bytestring + , BoundedChan + , containers + , xml + , Decimal + , time + , attoparsec + , stm + , extra + , errors + extra-lib-dirs: lib + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -threaded -rtsopts -with-rtsopts=-N + if os(windows) + extra-libraries: txmlconnector64 +