asakul
/
quik-connector
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

QuikBroker: removed ExceptT

master
Denis Tereshkin 9 years ago
parent
34e8ba36a4
commit
f5a29e8098
4 changed files with 91 additions and 88 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 83
      app/Main.hs
  2. 3
      quik-connector.cabal
  3. 6
      src/Broker/QuikBroker.hs
  4. 87
      src/Broker/QuikBroker/Trans2QuikApi.hs

83
app/Main.hs
Unescape View File

@ -34,8 +34,6 @@ import System.ZMQ4.ZAP
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe import Data.Maybe
import Control.Monad.Trans.Except
import Config import Config
forkBoundedChan :: Int -> BoundedChan Tick -> IO (ThreadId, BoundedChan Tick, BoundedChan QuoteSourceServerData) forkBoundedChan :: Int -> BoundedChan Tick -> IO (ThreadId, BoundedChan Tick, BoundedChan QuoteSourceServerData)
@ -73,48 +71,45 @@ main = do
(forkId, c1, c2) <- forkBoundedChan 10000 chan (forkId, c1, c2) <- forkBoundedChan 10000 chan
broker <- mkPaperBroker c1 1000000 ["demo"] brokerP <- mkPaperBroker c1 1000000 ["demo"]
eitherBrokerQ <- runExceptT $ mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config) brokerQ <- mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config)
case eitherBrokerQ of withContext (\ctx -> do
Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg withZapHandler ctx (\zap -> do
Right brokerQ -> zapSetWhitelist zap $ whitelist config
withContext (\ctx -> do zapSetBlacklist zap $ blacklist config
withZapHandler ctx (\zap -> do
zapSetWhitelist zap $ whitelist config case brokerClientCertificateDir config of
zapSetBlacklist zap $ blacklist config Just certFile -> do
certs <- loadCertificatesFromDirectory certFile
case brokerClientCertificateDir config of forM_ certs (\cert -> zapAddClientCertificate zap cert)
Just certFile -> do Nothing -> return ()
certs <- loadCertificatesFromDirectory certFile
forM_ certs (\cert -> zapAddClientCertificate zap cert) serverCert <- case brokerServerCertPath config of
Nothing -> return () Just certFile -> do
eitherCert <- loadCertificateFromFile certFile
serverCert <- case brokerServerCertPath config of case eitherCert of
Just certFile -> do Left errorMessage -> do
eitherCert <- loadCertificateFromFile certFile warningM "main" $ "Unable to load server certificate: " ++ errorMessage
case eitherCert of return Nothing
Left errorMessage -> do Right cert -> return $ Just cert
warningM "main" $ "Unable to load server certificate: " ++ errorMessage Nothing -> return Nothing
return Nothing let serverParams = defaultServerSecurityParams { sspDomain = Just "global",
Right cert -> return $ Just cert sspCertificate = serverCert }
Nothing -> return Nothing
let serverParams = defaultServerSecurityParams { sspDomain = Just "global", withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do
sspCertificate = serverCert } withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do
bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\_ -> do
withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do bracket (startBrokerServer [brokerP, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\_ -> do
withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do void $ Gtk.init Nothing
bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\_ -> do window <- new Gtk.Window [ #title := "Quik connector" ]
bracket (startBrokerServer [broker, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\_ -> do void $ on window #destroy Gtk.mainQuit
void $ Gtk.init Nothing #showAll window
window <- new Gtk.Window [ #title := "Quik connector" ] Gtk.main)
void $ on window #destroy Gtk.mainQuit infoM "main" "BRS down")
#showAll window debugM "main" "QS done")
Gtk.main) debugM "main" "TGTS done")
infoM "main" "BRS down") debugM "main" "ZMQTS done")
debugM "main" "QS done") debugM "main" "ZAP done")
debugM "main" "TGTS done")
debugM "main" "ZMQTS done")
debugM "main" "ZAP done")
void $ timeout 1000000 $ killThread forkId void $ timeout 1000000 $ killThread forkId
infoM "main" "Main thread done" infoM "main" "Main thread done"

3
quik-connector.cabal
Unescape View File

@ -23,7 +23,7 @@ library
, Broker.QuikBroker , Broker.QuikBroker
, Broker.QuikBroker.Trans2QuikApi , Broker.QuikBroker.Trans2QuikApi
, Network.Telegram , Network.Telegram
ghc-options: -Wincomplete-patterns ghc-options: -Wall -Wunsupported-calling-conventions
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, Win32 , Win32
, haskell-gi-base , haskell-gi-base
@ -66,6 +66,7 @@ library
, extra , extra
, incremental-parser , incremental-parser
, attoparsec , attoparsec
, safe-exceptions
default-language: Haskell2010 default-language: Haskell2010
-- extra-libraries: "user32" -- extra-libraries: "user32"
other-modules: System.Win32.XlParser other-modules: System.Win32.XlParser

6
src/Broker/QuikBroker.hs
Unescape View File

@ -49,13 +49,13 @@ maybeCall proj state arg = do
Just callback -> callback arg Just callback -> callback arg
Nothing -> return () Nothing -> return ()
mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> IO BrokerInterface
mkQuikBroker dllPath quikPath accs = do mkQuikBroker dllPath quikPath accs = do
q <- mkQuik dllPath quikPath q <- mkQuik dllPath quikPath
msgChan <- liftIO $ newBoundedChan 100 msgChan <- newBoundedChan 100
state <- liftIO $ newIORef QuikBrokerState { state <- newIORef QuikBrokerState {
notificationCallback = Nothing, notificationCallback = Nothing,
quik = q, quik = q,
orderMap = M.empty, orderMap = M.empty,

87
src/Broker/QuikBroker/Trans2QuikApi.hs
Unescape View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Broker.QuikBroker.Trans2QuikApi ( module Broker.QuikBroker.Trans2QuikApi (
Trans2QuikApi(..), Trans2QuikApi(..),
@ -22,14 +23,23 @@ import Control.Monad.IO.Class
import System.Win32.DLL import System.Win32.DLL
import System.Win32.Types import System.Win32.Types
import Control.Concurrent import Control.Concurrent
import Control.Exception.Safe
import Data.IORef import Data.IORef
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Calendar import Data.Time.Calendar
import Data.Ratio import Data.Ratio
import Data.Typeable
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
import System.Log.Logger import System.Log.Logger
type QuikErrorCode = LONG
data QuikException = QuikException T.Text QuikErrorCode
deriving (Show, Eq, Typeable)
instance Exception QuikException
ecSuccess = 0 ecSuccess = 0
ecFailed = 1 ecFailed = 1
ecQuikTerminalNotFound = 2 ecQuikTerminalNotFound = 2
@ -396,22 +406,21 @@ quikSendTransaction state transactionString = do
else return $ Right ()))) else return $ Right ())))
setCallbacks :: IORef Quik -> HlTransactionCallback -> HlOrderCallback -> HlTradeCallback -> ExceptT T.Text IO () setCallbacks :: IORef Quik -> HlTransactionCallback -> HlOrderCallback -> HlTradeCallback -> IO ()
setCallbacks quik transCb orCb tradeCb = setCallbacks quik transCb orCb tradeCb = atomicModifyIORef' quik (\s ->
liftIO $ atomicModifyIORef' quik (\s ->
( s { hlTransactionCallback = Just transCb, ( s { hlTransactionCallback = Just transCb,
hlOrderCallback = Just orCb, hlOrderCallback = Just orCb,
hlTradeCallback = Just tradeCb }, ())) hlTradeCallback = Just tradeCb }, ()))
mkQuik :: FilePath -> FilePath -> ExceptT T.Text IO (IORef Quik) mkQuik :: FilePath -> FilePath -> IO (IORef Quik)
mkQuik dllpath quikpath = do mkQuik dllpath quikpath = do
api <- loadQuikApi dllpath api <- loadQuikApi dllpath
liftIO $ debugM "Quik" "Dll loaded" debugM "Quik" "Dll loaded"
myTid <- liftIO myThreadId myTid <- myThreadId
state <- liftIO $ newIORef Quik { quikApi = api, state <- newIORef Quik { quikApi = api,
connectedToServer = False, connectedToServer = False,
connectedToDll = False, connectedToDll = False,
watchdogTid = myTid, watchdogTid = myTid,
@ -421,19 +430,19 @@ mkQuik dllpath quikpath = do
handledTrades = S.empty, handledTrades = S.empty,
handledOrders = S.empty } handledOrders = S.empty }
conncb' <- liftIO (mkConnectionStatusCallback (defaultConnectionCb state)) conncb' <- mkConnectionStatusCallback (defaultConnectionCb state)
transcb' <- liftIO (mkTransactionsReplyCallback (defaultTransactionReplyCb state)) transcb' <- mkTransactionsReplyCallback (defaultTransactionReplyCb state)
orcb' <- liftIO (mkOrderStatusCallback (defaultOrderCb state)) orcb' <- mkOrderStatusCallback (defaultOrderCb state)
tradecb' <- liftIO (mkTradeStatusCallback (defaultTradeCb state)) tradecb' <- mkTradeStatusCallback (defaultTradeCb state)
liftIO (atomicModifyIORef' state (\s -> (s { connectionCallback = conncb', atomicModifyIORef' state (\s -> (s { connectionCallback = conncb',
transactionCallback = transcb', transactionCallback = transcb',
orderCallback = orcb', orderCallback = orcb',
tradeCallback = tradecb' }, ()))) tradeCallback = tradecb' }, ()))
tid <- liftIO (forkIO $ watchdog quikpath state) tid <- forkIO $ watchdog quikpath state
liftIO $ atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ())) atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ()))
liftIO $ debugM "Quik" "mkQuik done" debugM "Quik" "mkQuik done"
return state return state
defaultConnectionCb :: IORef Quik -> LONG -> LONG -> LPSTR -> IO () defaultConnectionCb :: IORef Quik -> LONG -> LONG -> LPSTR -> IO ()
@ -533,31 +542,29 @@ watchdog quikpath state = do
then warningM "Quik.Watchdog" $ "Error: " ++ show err then warningM "Quik.Watchdog" $ "Error: " ++ show err
else forever $ do else forever $ do
conn <- connectedToDll <$> readIORef state conn <- connectedToDll <$> readIORef state
unless conn $ handle
withCString quikpath (\path -> do (\(QuikException errmsg rc) -> warningM "Quik.Watchdog" $ (T.unpack errmsg) ++ " (" ++ show rc ++ ")") $
err <- connect api path errorCode errorMsg 1024 unless conn $
if err /= ecSuccess && err /= ecAlreadyConnectedToQuik withCString quikpath (\path -> do
then warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err err <- connect api path errorCode errorMsg 1024
else withCString "" (\emptyStr -> do if err /= ecSuccess && err /= ecAlreadyConnectedToQuik
res <- (runExceptT $ do then warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err
throwIfErr $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024 else withCString "" (\emptyStr -> do
throwIfErr $ subscribeOrders api emptyStr emptyStr throwIfErr "setTransactionsReplyCallback returned error" $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024
liftIO $ startOrders api orcb throwIfErr "subscribeOrders returned error" $ subscribeOrders api emptyStr emptyStr
throwIfErr $ subscribeTrades api emptyStr emptyStr startOrders api orcb
liftIO $ startTrades api tradecb) throwIfErr "subscribeTrades returned error" $ subscribeTrades api emptyStr emptyStr
case res of startTrades api tradecb))
Left err -> warningM "Quik.Watchdog" $ "Unable to set callbacks: " ++ show err
Right _ -> debugM "Quik.Watchdog" "Callbacks are set"))
threadDelay 10000000)) threadDelay 10000000))
throwIfErr :: IO LONG -> ExceptT T.Text IO () throwIfErr :: T.Text -> IO LONG -> IO ()
throwIfErr action = do throwIfErr errmsg action = do
rc <- liftIO action rc <- action
if rc /= ecSuccess if rc /= ecSuccess
then throwE "Error" then throw $ QuikException errmsg rc
else return () else return ()
loadQuikApi :: FilePath -> ExceptT T.Text IO Trans2QuikApi loadQuikApi :: FilePath -> IO Trans2QuikApi
loadQuikApi path = do loadQuikApi path = do
dll <- castPtr <$> liftIO (loadLibrary path) dll <- castPtr <$> liftIO (loadLibrary path)
dll `orFail` "Unable to load Trans2quik.dll" dll `orFail` "Unable to load Trans2quik.dll"
@ -668,14 +675,14 @@ loadQuikApi path = do
} }
where 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 orFail myPtr t = if nullPtr == myPtr
then throwE t then throw $ QuikException t ecFailed
else return myPtr else return myPtr
tryLoad :: HMODULE -> String -> ExceptT T.Text IO (FunPtr a) tryLoad :: HMODULE -> String -> IO (FunPtr a)
tryLoad dll proc = do tryLoad dll proc = do
p <- liftIO (getProcAddress' dll proc) p <- getProcAddress' dll proc
p `orFail` ("Unable to load symbol: " `T.append` T.pack proc) p `orFail` ("Unable to load symbol: " `T.append` T.pack proc)
return $ castPtrToFunPtr p return $ castPtrToFunPtr p

Write Preview
Loading…
Cancel
Save