Update for changed libatrade API

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 }
 
+          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) (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")
-        ))
+                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"
 

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

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,11 +165,13 @@ 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
+        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

src/Broker/Protocol.hs

@@ -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 

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 {

src/Broker/QuikBroker/HsQuik.hs

@@ -1,5 +0,0 @@
-
-module Broker.QuikBroker.HsQuik (
-) where
-
-import Broker.QuikBroker.Trans2QuikApi

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))

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.