Initial commit

.gitignore

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

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

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.

README.md

@@ -0,0 +1 @@
+# transaq-connector

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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
+

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

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

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

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
+  }]

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
+

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

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
+

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

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

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
+