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. 11
      app/Main.hs
  2. 3
      quik-connector.cabal
  3. 6
      src/Broker/QuikBroker.hs
  4. 75
      src/Broker/QuikBroker/Trans2QuikApi.hs

11
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,11 +71,8 @@ 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
Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg
Right brokerQ ->
withContext (\ctx -> do withContext (\ctx -> do
withZapHandler ctx (\zap -> do withZapHandler ctx (\zap -> do
zapSetWhitelist zap $ whitelist config zapSetWhitelist zap $ whitelist config
@ -104,7 +99,7 @@ main = do
withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do
withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do withTelegramTradeSink (telegramToken config) (telegramChatId config) (\telegramTradeSink -> do
bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\_ -> 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 bracket (startBrokerServer [brokerP, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [telegramTradeSink, zmqTradeSink] serverParams) stopBrokerServer (\_ -> do
void $ Gtk.init Nothing void $ Gtk.init Nothing
window <- new Gtk.Window [ #title := "Quik connector" ] window <- new Gtk.Window [ #title := "Quik connector" ]
void $ on window #destroy Gtk.mainQuit void $ on window #destroy Gtk.mainQuit

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,

75
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
handle
(\(QuikException errmsg rc) -> warningM "Quik.Watchdog" $ (T.unpack errmsg) ++ " (" ++ show rc ++ ")") $
unless conn $ unless conn $
withCString quikpath (\path -> do withCString quikpath (\path -> do
err <- connect api path errorCode errorMsg 1024 err <- connect api path errorCode errorMsg 1024
if err /= ecSuccess && err /= ecAlreadyConnectedToQuik if err /= ecSuccess && err /= ecAlreadyConnectedToQuik
then warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err then warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err
else withCString "" (\emptyStr -> do else withCString "" (\emptyStr -> do
res <- (runExceptT $ do throwIfErr "setTransactionsReplyCallback returned error" $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024
throwIfErr $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024 throwIfErr "subscribeOrders returned error" $ subscribeOrders api emptyStr emptyStr
throwIfErr $ subscribeOrders api emptyStr emptyStr startOrders api orcb
liftIO $ startOrders api orcb throwIfErr "subscribeTrades returned error" $ subscribeTrades api emptyStr emptyStr
throwIfErr $ subscribeTrades api emptyStr emptyStr startTrades api tradecb))
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"))
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