diff --git a/app/Main.hs b/app/Main.hs index 72deb18..f285608 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -34,8 +34,6 @@ import System.ZMQ4.ZAP import qualified Data.Text as T import Data.Maybe -import Control.Monad.Trans.Except - import Config forkBoundedChan :: Int -> BoundedChan Tick -> IO (ThreadId, BoundedChan Tick, BoundedChan QuoteSourceServerData) @@ -73,48 +71,45 @@ main = do (forkId, c1, c2) <- forkBoundedChan 10000 chan - broker <- mkPaperBroker c1 1000000 ["demo"] - 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 -> - withContext (\ctx -> do - withZapHandler ctx (\zap -> do - zapSetWhitelist zap $ whitelist config - zapSetBlacklist zap $ blacklist config - - case brokerClientCertificateDir config of - Just certFile -> do - certs <- loadCertificatesFromDirectory certFile - forM_ certs (\cert -> zapAddClientCertificate zap cert) - Nothing -> return () - - serverCert <- case brokerServerCertPath config of - Just certFile -> do - eitherCert <- loadCertificateFromFile certFile - case eitherCert of - Left errorMessage -> do - warningM "main" $ "Unable to load server certificate: " ++ errorMessage - return Nothing - Right cert -> return $ Just cert - Nothing -> return Nothing - let serverParams = defaultServerSecurityParams { sspDomain = Just "global", - sspCertificate = serverCert } - - withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do - withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do - 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" ] - void $ on window #destroy Gtk.mainQuit - #showAll window - Gtk.main) - infoM "main" "BRS down") - debugM "main" "QS done") - debugM "main" "TGTS done") - debugM "main" "ZMQTS done") - debugM "main" "ZAP done") + brokerP <- mkPaperBroker c1 1000000 ["demo"] + brokerQ <- mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config) + withContext (\ctx -> do + withZapHandler ctx (\zap -> do + zapSetWhitelist zap $ whitelist config + zapSetBlacklist zap $ blacklist config + + case brokerClientCertificateDir config of + Just certFile -> do + certs <- loadCertificatesFromDirectory certFile + forM_ certs (\cert -> zapAddClientCertificate zap cert) + Nothing -> return () + + serverCert <- case brokerServerCertPath config of + Just certFile -> do + eitherCert <- loadCertificateFromFile certFile + case eitherCert of + Left errorMessage -> do + warningM "main" $ "Unable to load server certificate: " ++ errorMessage + return Nothing + Right cert -> return $ Just cert + Nothing -> return Nothing + let serverParams = defaultServerSecurityParams { sspDomain = Just "global", + sspCertificate = serverCert } + + withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do + withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do + bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\_ -> do + bracket (startBrokerServer [brokerP, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\_ -> do + void $ Gtk.init Nothing + window <- new Gtk.Window [ #title := "Quik connector" ] + void $ on window #destroy Gtk.mainQuit + #showAll window + Gtk.main) + infoM "main" "BRS down") + debugM "main" "QS done") + debugM "main" "TGTS done") + debugM "main" "ZMQTS done") + debugM "main" "ZAP done") void $ timeout 1000000 $ killThread forkId infoM "main" "Main thread done" diff --git a/quik-connector.cabal b/quik-connector.cabal index 49a5da3..d11e15b 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -23,7 +23,7 @@ library , Broker.QuikBroker , Broker.QuikBroker.Trans2QuikApi , Network.Telegram - ghc-options: -Wincomplete-patterns + ghc-options: -Wall -Wunsupported-calling-conventions build-depends: base >= 4.7 && < 5 , Win32 , haskell-gi-base @@ -66,6 +66,7 @@ library , extra , incremental-parser , attoparsec + , safe-exceptions default-language: Haskell2010 -- extra-libraries: "user32" other-modules: System.Win32.XlParser diff --git a/src/Broker/QuikBroker.hs b/src/Broker/QuikBroker.hs index 085947a..3a8b8a5 100644 --- a/src/Broker/QuikBroker.hs +++ b/src/Broker/QuikBroker.hs @@ -49,13 +49,13 @@ maybeCall proj state arg = do Just callback -> callback arg Nothing -> return () -mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface +mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> IO BrokerInterface mkQuikBroker dllPath quikPath accs = do q <- mkQuik dllPath quikPath - msgChan <- liftIO $ newBoundedChan 100 + msgChan <- newBoundedChan 100 - state <- liftIO $ newIORef QuikBrokerState { + state <- newIORef QuikBrokerState { notificationCallback = Nothing, quik = q, orderMap = M.empty, diff --git a/src/Broker/QuikBroker/Trans2QuikApi.hs b/src/Broker/QuikBroker/Trans2QuikApi.hs index 8531b14..92fed6a 100644 --- a/src/Broker/QuikBroker/Trans2QuikApi.hs +++ b/src/Broker/QuikBroker/Trans2QuikApi.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} module Broker.QuikBroker.Trans2QuikApi ( Trans2QuikApi(..), @@ -22,14 +23,23 @@ import Control.Monad.IO.Class import System.Win32.DLL import System.Win32.Types import Control.Concurrent +import Control.Exception.Safe import Data.IORef import Data.Time.Clock import Data.Time.Calendar import Data.Ratio +import Data.Typeable import qualified Data.Set as S import qualified Data.Text as T import System.Log.Logger +type QuikErrorCode = LONG + +data QuikException = QuikException T.Text QuikErrorCode + deriving (Show, Eq, Typeable) + +instance Exception QuikException + ecSuccess = 0 ecFailed = 1 ecQuikTerminalNotFound = 2 @@ -396,22 +406,21 @@ quikSendTransaction state transactionString = do else return $ Right ()))) -setCallbacks :: IORef Quik -> HlTransactionCallback -> HlOrderCallback -> HlTradeCallback -> ExceptT T.Text IO () -setCallbacks quik transCb orCb tradeCb = - liftIO $ atomicModifyIORef' quik (\s -> +setCallbacks :: IORef Quik -> HlTransactionCallback -> HlOrderCallback -> HlTradeCallback -> IO () +setCallbacks quik transCb orCb tradeCb = atomicModifyIORef' quik (\s -> ( s { hlTransactionCallback = Just transCb, hlOrderCallback = Just orCb, hlTradeCallback = Just tradeCb }, ())) -mkQuik :: FilePath -> FilePath -> ExceptT T.Text IO (IORef Quik) +mkQuik :: FilePath -> FilePath -> IO (IORef Quik) mkQuik dllpath quikpath = do api <- loadQuikApi dllpath - liftIO $ debugM "Quik" "Dll loaded" + debugM "Quik" "Dll loaded" - myTid <- liftIO myThreadId - state <- liftIO $ newIORef Quik { quikApi = api, + myTid <- myThreadId + state <- newIORef Quik { quikApi = api, connectedToServer = False, connectedToDll = False, watchdogTid = myTid, @@ -421,19 +430,19 @@ mkQuik dllpath quikpath = do handledTrades = S.empty, handledOrders = S.empty } - conncb' <- liftIO (mkConnectionStatusCallback (defaultConnectionCb state)) - transcb' <- liftIO (mkTransactionsReplyCallback (defaultTransactionReplyCb state)) - orcb' <- liftIO (mkOrderStatusCallback (defaultOrderCb state)) - tradecb' <- liftIO (mkTradeStatusCallback (defaultTradeCb state)) + conncb' <- mkConnectionStatusCallback (defaultConnectionCb state) + transcb' <- mkTransactionsReplyCallback (defaultTransactionReplyCb state) + orcb' <- mkOrderStatusCallback (defaultOrderCb state) + tradecb' <- mkTradeStatusCallback (defaultTradeCb state) - liftIO (atomicModifyIORef' state (\s -> (s { connectionCallback = conncb', + atomicModifyIORef' state (\s -> (s { connectionCallback = conncb', transactionCallback = transcb', orderCallback = orcb', - tradeCallback = tradecb' }, ()))) + tradeCallback = tradecb' }, ())) - tid <- liftIO (forkIO $ watchdog quikpath state) - liftIO $ atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ())) - liftIO $ debugM "Quik" "mkQuik done" + tid <- forkIO $ watchdog quikpath state + atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ())) + debugM "Quik" "mkQuik done" return state defaultConnectionCb :: IORef Quik -> LONG -> LONG -> LPSTR -> IO () @@ -533,31 +542,29 @@ watchdog quikpath state = do then warningM "Quik.Watchdog" $ "Error: " ++ show err else forever $ do conn <- connectedToDll <$> readIORef state - unless conn $ - withCString quikpath (\path -> do - err <- connect api path errorCode errorMsg 1024 - if err /= ecSuccess && err /= ecAlreadyConnectedToQuik - then warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err - else withCString "" (\emptyStr -> do - res <- (runExceptT $ do - throwIfErr $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024 - throwIfErr $ subscribeOrders api emptyStr emptyStr - liftIO $ startOrders api orcb - throwIfErr $ subscribeTrades api emptyStr emptyStr - liftIO $ startTrades api tradecb) - case res of - Left err -> warningM "Quik.Watchdog" $ "Unable to set callbacks: " ++ show err - Right _ -> debugM "Quik.Watchdog" "Callbacks are set")) + handle + (\(QuikException errmsg rc) -> warningM "Quik.Watchdog" $ (T.unpack errmsg) ++ " (" ++ show rc ++ ")") $ + unless conn $ + withCString quikpath (\path -> do + err <- connect api path errorCode errorMsg 1024 + if err /= ecSuccess && err /= ecAlreadyConnectedToQuik + then warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err + else withCString "" (\emptyStr -> do + throwIfErr "setTransactionsReplyCallback returned error" $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024 + throwIfErr "subscribeOrders returned error" $ subscribeOrders api emptyStr emptyStr + startOrders api orcb + throwIfErr "subscribeTrades returned error" $ subscribeTrades api emptyStr emptyStr + startTrades api tradecb)) threadDelay 10000000)) -throwIfErr :: IO LONG -> ExceptT T.Text IO () -throwIfErr action = do - rc <- liftIO action +throwIfErr :: T.Text -> IO LONG -> IO () +throwIfErr errmsg action = do + rc <- action if rc /= ecSuccess - then throwE "Error" + then throw $ QuikException errmsg rc else return () -loadQuikApi :: FilePath -> ExceptT T.Text IO Trans2QuikApi +loadQuikApi :: FilePath -> IO Trans2QuikApi loadQuikApi path = do dll <- castPtr <$> liftIO (loadLibrary path) dll `orFail` "Unable to load Trans2quik.dll" @@ -668,14 +675,14 @@ loadQuikApi path = do } where - orFail :: Ptr p -> T.Text -> ExceptT T.Text IO (Ptr p) + orFail :: Ptr p -> T.Text -> IO (Ptr p) orFail myPtr t = if nullPtr == myPtr - then throwE t + then throw $ QuikException t ecFailed else return myPtr - tryLoad :: HMODULE -> String -> ExceptT T.Text IO (FunPtr a) + tryLoad :: HMODULE -> String -> IO (FunPtr a) tryLoad dll proc = do - p <- liftIO (getProcAddress' dll proc) + p <- getProcAddress' dll proc p `orFail` ("Unable to load symbol: " `T.append` T.pack proc) return $ castPtrToFunPtr p