diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 index 0000000..326d97d --- /dev/null +++ b/app/Config.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings, OverloadedLabels #-} + +module Config ( + TableConfig(..), + Config(..), + readConfig + +) where + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Vector as V +import qualified Data.Text as T + +data TableConfig = TableConfig { + parserId :: String, + tableName :: String, + tableParams :: Value +} deriving (Show) + +data Config = Config { + quotesourceEndpoint :: String, + brokerserverEndpoint :: String, + whitelist :: [T.Text], + blacklist :: [T.Text], + brokerServerCertPath :: Maybe FilePath, + brokerClientCertificateDir :: Maybe FilePath, + tables :: [TableConfig], + quikPath :: String, + dllPath :: String, + quikAccounts :: [T.Text], + tradeSink :: T.Text, + telegramToken :: T.Text, + telegramChatId :: T.Text +} deriving (Show) + +readConfig :: String -> IO Config +readConfig fname = do + content <- BL.readFile fname + case decode content >>= parseMaybe parseConfig of + Just config -> return config + Nothing -> error "Unable to load config" + +parseConfig :: Value -> Parser Config +parseConfig = withObject "object" $ \obj -> do + qse <- obj .: "quotesource-endpoint" + bse <- obj .: "brokerserver-endpoint" + whitelist' <- obj .:? "whitelist" .!= [] + blacklist' <- obj .:? "blacklist" .!= [] + serverCert <- obj .:? "broker_server_certificate" + clientCerts <- obj .:? "broker_client_certificates" + rt <- case HM.lookup "tables" obj of + Just v -> parseTables v + Nothing -> fail "Expected tables array" + qp <- obj .: "quik-path" + dp <- obj .: "dll-path" + trsink <- obj .: "trade-sink" + tgToken <- obj .: "telegram-token" + tgChatId <- obj .: "telegram-chatid" + accs <- V.toList <$> obj .: "accounts" + return Config { quotesourceEndpoint = qse, + brokerserverEndpoint = bse, + whitelist = whitelist', + blacklist = blacklist', + brokerServerCertPath = serverCert, + brokerClientCertificateDir = clientCerts, + tables = rt, + quikPath = qp, + dllPath = dp, + quikAccounts = fmap T.pack accs, + tradeSink = trsink, + telegramToken = tgToken, + telegramChatId = tgChatId } + where + parseTables :: Value -> Parser [TableConfig] + parseTables = withArray "array" $ \arr -> mapM parseTableConfig (V.toList arr) + + parseTableConfig :: Value -> Parser TableConfig + parseTableConfig = withObject "object" $ \obj -> do + pid <- obj .: "parser-id" + tn <- obj .: "table-name" + params <- case HM.lookup "params" obj of + Just x -> return x + Nothing -> return $ Object HM.empty + return TableConfig { + parserId = pid, + tableName = tn, + tableParams = params } + diff --git a/app/Main.hs b/app/Main.hs index ada2eac..72deb18 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,8 +8,6 @@ import Control.Concurrent hiding (readChan, writeChan) import Control.Monad import Control.Exception import Control.Error.Util -import Control.Monad.IO.Class -import Data.IORef import qualified GI.Gtk as Gtk import Data.GI.Base import Control.Concurrent.BoundedChan @@ -21,7 +19,6 @@ import ATrade.QuoteSource.Server import ATrade.Broker.TradeSinks.ZMQTradeSink import ATrade.Broker.TradeSinks.TelegramTradeSink import ATrade.Broker.Server -import ATrade.Broker.Protocol import Broker.PaperBroker import Broker.QuikBroker @@ -34,109 +31,26 @@ import System.Log.Formatter import System.ZMQ4 import System.ZMQ4.ZAP -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HM -import qualified Data.Vector as V import qualified Data.Text as T import Data.Maybe import Control.Monad.Trans.Except -import Broker.QuikBroker.Trans2QuikApi - -import Network.Telegram -import Network.Connection -import Network.HTTP.Client -import Network.HTTP.Client.TLS - -data TableConfig = TableConfig { - parserId :: String, - tableName :: String, - tableParams :: Value -} deriving (Show) - -data Config = Config { - quotesourceEndpoint :: String, - brokerserverEndpoint :: String, - whitelist :: [T.Text], - blacklist :: [T.Text], - brokerServerCertPath :: Maybe FilePath, - brokerClientCertificateDir :: Maybe FilePath, - tables :: [TableConfig], - quikPath :: String, - dllPath :: String, - quikAccounts :: [T.Text], - tradeSink :: T.Text, - telegramToken :: T.Text, - telegramChatId :: T.Text -} deriving (Show) - -readConfig :: String -> IO Config -readConfig fname = do - content <- BL.readFile fname - case decode content >>= parseMaybe parseConfig of - Just config -> return config - Nothing -> error "Unable to load config" - -parseConfig :: Value -> Parser Config -parseConfig = withObject "object" $ \obj -> do - qse <- obj .: "quotesource-endpoint" - bse <- obj .: "brokerserver-endpoint" - whitelist' <- obj .:? "whitelist" .!= [] - blacklist' <- obj .:? "blacklist" .!= [] - serverCert <- obj .:? "broker_server_certificate" - clientCerts <- obj .:? "broker_client_certificates" - rt <- case HM.lookup "tables" obj of - Just v -> parseTables v - Nothing -> fail "Expected tables array" - qp <- obj .: "quik-path" - dp <- obj .: "dll-path" - trsink <- obj .: "trade-sink" - tgToken <- obj .: "telegram-token" - tgChatId <- obj .: "telegram-chatid" - accs <- V.toList <$> obj .: "accounts" - return Config { quotesourceEndpoint = qse, - brokerserverEndpoint = bse, - whitelist = whitelist', - blacklist = blacklist', - brokerServerCertPath = serverCert, - brokerClientCertificateDir = clientCerts, - tables = rt, - quikPath = qp, - dllPath = dp, - quikAccounts = fmap T.pack accs, - tradeSink = trsink, - telegramToken = tgToken, - telegramChatId = tgChatId } - where - parseTables :: Value -> Parser [TableConfig] - parseTables = withArray "array" $ \arr -> mapM parseTableConfig (V.toList arr) - - parseTableConfig :: Value -> Parser TableConfig - parseTableConfig = withObject "object" $ \obj -> do - pid <- obj .: "parser-id" - tn <- obj .: "table-name" - params <- case HM.lookup "params" obj of - Just x -> return x - Nothing -> return $ Object HM.empty - return TableConfig { - parserId = pid, - tableName = tn, - tableParams = params } + +import Config forkBoundedChan :: Int -> BoundedChan Tick -> IO (ThreadId, BoundedChan Tick, BoundedChan QuoteSourceServerData) -forkBoundedChan size source = do +forkBoundedChan size sourceChan = do sink <- newBoundedChan size sinkQss <- newBoundedChan size tid <- forkIO $ forever $ do - v <- readChan source + v <- readChan sourceChan writeChan sink v writeChan sinkQss (QSSTick v) return (tid, sink, sinkQss) +initLogging :: IO () initLogging = do handler <- streamHandler stderr DEBUG >>= (\x -> return $ @@ -155,14 +69,12 @@ main = do infoM "main" "Config loaded" chan <- newBoundedChan 10000 infoM "main" "Starting data import server" - dis <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade" + _ <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade" (forkId, c1, c2) <- forkBoundedChan 10000 chan broker <- mkPaperBroker c1 1000000 ["demo"] - man <- newManager (mkManagerSettings (TLSSettingsSimple { settingDisableCertificateValidation = True, settingDisableSession = False, settingUseServerName = False }) Nothing) - infoM "main" "Http manager created" - eitherBrokerQ <- runExceptT $ mkQuikBroker man (dllPath config) (quikPath config) (quikAccounts config) + eitherBrokerQ <- runExceptT $ mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config) case eitherBrokerQ of Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg Right brokerQ -> @@ -172,8 +84,8 @@ main = do zapSetBlacklist zap $ blacklist config case brokerClientCertificateDir config of - Just path -> do - certs <- loadCertificatesFromDirectory path + Just certFile -> do + certs <- loadCertificatesFromDirectory certFile forM_ certs (\cert -> zapAddClientCertificate zap cert) Nothing -> return () @@ -181,8 +93,8 @@ main = do Just certFile -> do eitherCert <- loadCertificateFromFile certFile case eitherCert of - Left err -> do - warningM "main" $ "Unable to load server certificate: " ++ err + Left errorMessage -> do + warningM "main" $ "Unable to load server certificate: " ++ errorMessage return Nothing Right cert -> return $ Just cert Nothing -> return Nothing @@ -191,11 +103,11 @@ main = do withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do - bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\qsServer -> do - bracket (startBrokerServer [broker, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\broServer -> do - Gtk.init Nothing + bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\_ -> do + bracket (startBrokerServer [broker, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\_ -> do + void $ Gtk.init Nothing window <- new Gtk.Window [ #title := "Quik connector" ] - on window #destroy Gtk.mainQuit + void $ on window #destroy Gtk.mainQuit #showAll window Gtk.main) infoM "main" "BRS down") @@ -203,10 +115,11 @@ main = do debugM "main" "TGTS done") debugM "main" "ZMQTS done") debugM "main" "ZAP done") - timeout 1000000 $ killThread forkId + void $ timeout 1000000 $ killThread forkId infoM "main" "Main thread done" -loadCertificatesFromDirectory path = do - files <- listDirectory path +loadCertificatesFromDirectory :: FilePath -> IO [CurveCertificate] +loadCertificatesFromDirectory filepath = do + files <- listDirectory filepath catMaybes <$> forM files (\file -> hush <$> loadCertificateFromFile file) diff --git a/quik-connector.cabal b/quik-connector.cabal index 9c3c19e..49a5da3 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -75,7 +75,7 @@ library executable quik-connector-exe hs-source-dirs: app main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror build-depends: base , quik-connector , Win32 @@ -100,6 +100,7 @@ executable quik-connector-exe , directory , errors default-language: Haskell2010 + other-modules: Config -- extra-libraries: "user32" test-suite quik-connector-test diff --git a/src/Broker/PaperBroker.hs b/src/Broker/PaperBroker.hs index 0e415a4..a2ea8b3 100644 --- a/src/Broker/PaperBroker.hs +++ b/src/Broker/PaperBroker.hs @@ -96,21 +96,28 @@ executePendingOrders tick state = do atomicModifyIORef' state (\s -> (s { pendingOrders = L.filter (\order -> orderId order `L.notElem` executedIds) (pendingOrders s)}, ())) where execute order = - case orderPrice order of - Market -> do - executeAtTick state order tick - return $ Just $ orderId order - Limit price -> executeLimitAt price order - _ -> return Nothing + if security tick == orderSecurity order + then + case orderPrice order of + Market -> do + debugM "PaperBroker" "Executing: pending market order" + executeAtTick state order tick + return $ Just $ orderId order + Limit price -> do + executeLimitAt price order + _ -> return Nothing + else return Nothing executeLimitAt price order = case orderOperation order of Buy -> if (datatype tick == Price && price > value tick && value tick > 0) || (datatype tick == BestOffer && price > value tick && value tick > 0) then do + debugM "PaperBroker" $ "[1]Executing: pending limit order: " ++ show (security tick) ++ "/" ++ show (orderSecurity order) executeAtTick state order $ tick { value = price } return $ Just $ orderId order else return Nothing Sell -> if (datatype tick == Price && price < value tick && value tick > 0) || (datatype tick == BestBid && price < value tick && value tick > 0) then do + debugM "PaperBroker" $ "[2]Executing: pending limit order: " ++ show (security tick) ++ "/" ++ show (orderSecurity order) executeAtTick state order $ tick { value = price } return $ Just $ orderId order else return Nothing @@ -173,6 +180,7 @@ pbSubmitOrder state order = do then rejectOrder state order else do tm <- tickMap <$> readIORef state + debugM "PaperBroker" $ "Limit order submitted, looking up: " ++ show key case M.lookup key tm of Nothing -> do let newOrder = order { orderState = Submitted } @@ -180,7 +188,9 @@ pbSubmitOrder state order = do maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted Just tick -> if ((orderOperation order == Buy) && (value tick < price)) || ((orderOperation order == Sell) && (value tick > price)) - then executeAtTick state order tick + then do + maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted + executeAtTick state order tick else do let newOrder = order { orderState = Submitted } atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , pendingOrders = newOrder : pendingOrders s}, ())) diff --git a/src/Broker/QuikBroker.hs b/src/Broker/QuikBroker.hs index 5da5816..085947a 100644 --- a/src/Broker/QuikBroker.hs +++ b/src/Broker/QuikBroker.hs @@ -28,8 +28,6 @@ import Control.Monad.Trans.Except import Control.Monad.IO.Class import System.Log.Logger -import Network.Telegram - import Safe type QuikOrderId = Integer @@ -51,8 +49,8 @@ maybeCall proj state arg = do Just callback -> callback arg Nothing -> return () -mkQuikBroker :: Manager -> FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface -mkQuikBroker man dllPath quikPath accs = do +mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface +mkQuikBroker dllPath quikPath accs = do q <- mkQuik dllPath quikPath msgChan <- liftIO $ newBoundedChan 100