From 9ac9e8a7138a93afdaa64cb0869d11f2b3944b2d Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Tue, 27 Jun 2017 00:13:58 +0700 Subject: [PATCH] Update for changed libatrade API --- app/Main.hs | 32 +++++++++++----------- quik-connector.cabal | 10 ++++--- src/Broker/PaperBroker.hs | 48 +++++++++++++++++++-------------- src/Broker/Protocol.hs | 44 ------------------------------ src/Broker/QuikBroker.hs | 33 ++++------------------- src/Broker/QuikBroker/HsQuik.hs | 5 ---- src/Network/Telegram.hs | 9 ++++--- stack.yaml | 2 +- 8 files changed, 62 insertions(+), 121 deletions(-) delete mode 100644 src/Broker/Protocol.hs delete mode 100644 src/Broker/QuikBroker/HsQuik.hs diff --git a/app/Main.hs b/app/Main.hs index d1dfcf2..8c0741b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, OverloadedLabels #-} module Main where import System.IO @@ -10,13 +10,16 @@ import Control.Exception import Control.Error.Util import Control.Monad.IO.Class import Data.IORef -import Graphics.UI.Gtk hiding (Action, backspace) +import qualified GI.Gtk as Gtk +import Data.GI.Base import Control.Concurrent.BoundedChan import ATrade.Types import QuoteSource.TableParsers.AllParamsTableParser import QuoteSource.TableParser 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 @@ -158,9 +161,7 @@ main = do 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) (Just (telegramToken config, telegramChatId config)) - tgCtx <- mkTelegramContext man (telegramToken config) - sendMessage tgCtx (telegramChatId config) "Goldmine-Quik connector started" + eitherBrokerQ <- runExceptT $ mkQuikBroker man (dllPath config) (quikPath config) (quikAccounts config) case eitherBrokerQ of Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg Right brokerQ -> @@ -187,17 +188,16 @@ main = do let serverParams = defaultServerSecurityParams { sspDomain = Just "global", sspCertificate = serverCert } - bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\qsServer -> do - bracket (startBrokerServer [broker, brokerQ] ctx (T.pack $ brokerserverEndpoint config) (tradeSink config) serverParams) stopBrokerServer (\broServer -> do - void initGUI - window <- windowNew - window `on` deleteEvent $ do - liftIO mainQuit - return False - widgetShowAll window - mainGUI) - infoM "main" "BRS down") - )) + withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> + withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> + 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 + window <- new Gtk.Window [ #title := "Quik connector" ] + on window #destroy Gtk.mainQuit + #showAll window + Gtk.main) + infoM "main" "BRS down"))))) killThread forkId infoM "main" "Main thread done" diff --git a/quik-connector.cabal b/quik-connector.cabal index 4d5f744..9c3c19e 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -26,7 +26,8 @@ library ghc-options: -Wincomplete-patterns build-depends: base >= 4.7 && < 5 , Win32 - , gtk + , haskell-gi-base + , gi-gtk , binary , data-binary-ieee754 , bytestring @@ -66,7 +67,7 @@ library , incremental-parser , attoparsec default-language: Haskell2010 - extra-libraries: "user32" +-- extra-libraries: "user32" other-modules: System.Win32.XlParser , System.Win32.DDE @@ -78,7 +79,8 @@ executable quik-connector-exe build-depends: base , quik-connector , Win32 - , gtk + , haskell-gi-base + , gi-gtk , BoundedChan , hslogger , aeson @@ -98,7 +100,7 @@ executable quik-connector-exe , directory , errors default-language: Haskell2010 - extra-libraries: "user32" +-- extra-libraries: "user32" test-suite quik-connector-test type: exitcode-stdio-1.0 diff --git a/src/Broker/PaperBroker.hs b/src/Broker/PaperBroker.hs index aa82835..27e287e 100644 --- a/src/Broker/PaperBroker.hs +++ b/src/Broker/PaperBroker.hs @@ -104,12 +104,12 @@ executePendingOrders tick state = do _ -> return Nothing executeLimitAt price order = case orderOperation order of - Buy -> if (datatype tick == Price && price > value tick) || (datatype tick == BestOffer && price > value tick) + Buy -> if (datatype tick == Price && price > value tick && value tick > 0) || (datatype tick == BestOffer && price > value tick && value tick > 0) then do executeAtTick state order $ tick { value = price } return $ Just $ orderId order else return Nothing - Sell -> if (datatype tick == Price && price < value tick) || (datatype tick == BestBid && price < value tick) + Sell -> if (datatype tick == Price && price < value tick && value tick > 0) || (datatype tick == BestBid && price < value tick && value tick > 0) then do executeAtTick state order $ tick { value = price } return $ Just $ orderId order @@ -146,6 +146,12 @@ executeAtTick state order tick = do maybeCall notificationCallback state $ TradeNotification $ mkTrade tick order ts maybeCall notificationCallback state $ OrderNotification (orderId order) Executed +rejectOrder state order = do + let newOrder = order { orderState = Rejected } in + atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ())) + maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted + maybeCall notificationCallback state $ OrderNotification (orderId order) Rejected + pbSubmitOrder :: IORef PaperBrokerState -> Order -> IO () pbSubmitOrder state order = do infoM "PaperBroker" $ "Submitted order: " ++ show order @@ -159,24 +165,26 @@ pbSubmitOrder state order = do executeMarketOrder state order = do tm <- tickMap <$> readIORef state case M.lookup key tm of - Nothing -> let newOrder = order { orderState = OrderError } in - atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ())) - - Just tick -> executeAtTick state order tick - submitLimitOrder price state order = do - tm <- tickMap <$> readIORef state - case M.lookup key tm of - Nothing -> do - let newOrder = order { orderState = Submitted } - atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ())) - 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 - else do - let newOrder = order { orderState = Submitted } - atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , pendingOrders = newOrder : pendingOrders s}, ())) - maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted + Nothing -> rejectOrder state order + Just tick -> if orderQuantity order /= 0 + then executeAtTick state order tick + else rejectOrder state order + submitLimitOrder price state order = if orderQuantity order == 0 + then rejectOrder state order + else do + tm <- tickMap <$> readIORef state + case M.lookup key tm of + Nothing -> do + let newOrder = order { orderState = Submitted } + atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ())) + 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 + else do + let newOrder = order { orderState = Submitted } + atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , pendingOrders = newOrder : pendingOrders s}, ())) + maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted submitStopOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order submitStopMarketOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order diff --git a/src/Broker/Protocol.hs b/src/Broker/Protocol.hs deleted file mode 100644 index 44ba78c..0000000 --- a/src/Broker/Protocol.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Broker.Protocol ( -) where - -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import Data.Aeson -import Data.Int -import Broker - -type RequestSqnum = Int64 - -data BrokerServerRequest = RequestSubmitOrder RequestSqnum Order - | RequestCancelOrder RequestSqnum OrderId - | RequestNotifications RequestSqnum - -data BrokerServerResponse = ResponseOrderSubmitted OrderId - | ResponseOrderCancelled - | ResponseNotifications [Notification] - -data Notification = OrderNotification OrderId OrderState | TradeNotification Trade - -instance FromJSON Notification where - parseJSON = withObject "notification" (\obj -> do - tradeJson <- obj .: "trade" - case tradeJson of - Just v -> parseTrade v - Nothing -> do - orderNotification <- obj .: "order-state" - case orderNotification of - Just v -> parseOrder v - Nothing -> fail "Invalid notification") - where - parseTrade v = TradeNotification <$> parseJSON v - parseOrder (Object o) = case HM.lookup "order-state" o of - Just v -> withObject "object" (\os -> do - oid <- os .: "order-id" - ns <- os .: "new-state" - return $ OrderNotification oid ns) v - Nothing -> fail "Should be order-state" - -instance ToJSON Notification where - toJSON (OrderNotification oid diff --git a/src/Broker/QuikBroker.hs b/src/Broker/QuikBroker.hs index 511fb7d..5da5816 100644 --- a/src/Broker/QuikBroker.hs +++ b/src/Broker/QuikBroker.hs @@ -40,9 +40,7 @@ data QuikBrokerState = QuikBrokerState { orderMap :: M.Map OrderId Order, orderIdMap :: BM.Bimap QuikOrderId OrderId, trans2orderid :: M.Map Integer Order, - transIdCounter :: Integer, - messageChan :: BoundedChan T.Text, - messageTid :: Maybe ThreadId + transIdCounter :: Integer } nextTransId state = atomicModifyIORef' state (\s -> (s { transIdCounter = transIdCounter s + 1 }, transIdCounter s)) @@ -53,26 +51,11 @@ maybeCall proj state arg = do Just callback -> callback arg Nothing -> return () -messageThread tgCtx chatId msgChan = forever $ do - maybeMsg <- tryReadChan msgChan - case maybeMsg of - Just msg -> do - sendMessage tgCtx chatId msg - warningM "Quik.Telegram" $ "Telegram message sent: " ++ T.unpack msg - Nothing -> threadDelay 500000 - - -mkQuikBroker :: Manager -> FilePath -> FilePath -> [T.Text] -> Maybe (T.Text, T.Text) -> ExceptT T.Text IO BrokerInterface -mkQuikBroker man dllPath quikPath accs tgParams = do +mkQuikBroker :: Manager -> FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface +mkQuikBroker man dllPath quikPath accs = do q <- mkQuik dllPath quikPath msgChan <- liftIO $ newBoundedChan 100 - msgTid <- liftIO $ case tgParams of - Nothing -> return Nothing - Just (tgToken, chatId) -> do - tgCtx <- mkTelegramContext man tgToken - tid <- forkIO $ messageThread tgCtx chatId msgChan - return $ Just tid state <- liftIO $ newIORef QuikBrokerState { notificationCallback = Nothing, @@ -80,9 +63,7 @@ mkQuikBroker man dllPath quikPath accs tgParams = do orderMap = M.empty, orderIdMap = BM.empty, trans2orderid = M.empty, - transIdCounter = 1, - messageChan = msgChan, - messageTid = msgTid + transIdCounter = 1 } setCallbacks q (qbTransactionCallback state) (qbOrderCallback state) (qbTradeCallback state) @@ -222,11 +203,7 @@ qbTradeCallback state quiktrade = do idMap <- orderIdMap <$> readIORef state debugM "Quik" $ "Trade: " ++ show quiktrade case BM.lookup (qtOrderId quiktrade) idMap >>= flip M.lookup orders of - Just order -> do - msgChan <- messageChan <$> readIORef state - tryWriteChan msgChan $ TL.toStrict $ format "Trade: {} of {} at {} for account {} ({}/{})" - (show (tradeOperation (tradeFor order)), orderSecurity order, qtPrice quiktrade, orderAccountId order, (strategyId . orderSignalId) order, (signalName . orderSignalId) order) - maybeCall notificationCallback state (TradeNotification $ tradeFor order) + Just order -> maybeCall notificationCallback state (TradeNotification $ tradeFor order) Nothing -> warningM "Quik" $ "Incoming trade for unknown order: " ++ show quiktrade where tradeFor order = Trade { diff --git a/src/Broker/QuikBroker/HsQuik.hs b/src/Broker/QuikBroker/HsQuik.hs deleted file mode 100644 index 5bbb8df..0000000 --- a/src/Broker/QuikBroker/HsQuik.hs +++ /dev/null @@ -1,5 +0,0 @@ - -module Broker.QuikBroker.HsQuik ( -) where - -import Broker.QuikBroker.Trans2QuikApi diff --git a/src/Network/Telegram.hs b/src/Network/Telegram.hs index 3f333b4..c5b6444 100644 --- a/src/Network/Telegram.hs +++ b/src/Network/Telegram.hs @@ -18,17 +18,20 @@ import qualified Data.ByteString.UTF8 as BU8 import Data.Aeson import Data.Aeson.Types +type TelegramApiToken = T.Text +type TelegramChatId = T.Text + data TelegramContext = TelegramContext { - tgToken :: T.Text, + tgToken :: TelegramApiToken, httpMan :: Manager } -mkTelegramContext :: Manager -> T.Text -> IO TelegramContext +mkTelegramContext :: Manager -> TelegramApiToken -> IO TelegramContext mkTelegramContext man token = do return TelegramContext { httpMan = man, tgToken = token } -sendMessage :: TelegramContext -> T.Text -> T.Text -> IO () +sendMessage :: TelegramContext -> TelegramChatId -> T.Text -> IO () sendMessage ctx chatId text = do req <- parseUrl $ "https://api.telegram.org/bot" ++ (T.unpack $ tgToken ctx) ++ "/sendMessage" void $ withResponse (req { method = "POST", requestHeaders = [("Content-Type", BU8.fromString "application/json")], requestBody = (RequestBodyLBS . encode) (object ["chat_id" .= chatId, "text" .= text]) }) (httpMan ctx) (\resp -> brConsume (responseBody resp)) diff --git a/stack.yaml b/stack.yaml index b94bd4f..4811efe 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-7.7 +resolver: lts-8.18 # User packages to be built. # Various formats can be used as shown in the example below.