QuikBroker: removed ExceptT

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"
 

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

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,

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