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

Quik Broker

master
Denis Tereshkin 9 years ago
parent
d542a7e33c
commit
80e8aefc39
6 changed files with 569 additions and 194 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. 34
      app/Main.hs
  2. 4
      quik-connector.cabal
  3. 9
      src/Broker/PaperBroker.hs
  4. 205
      src/Broker/QuikBroker.hs
  5. 505
      src/Broker/QuikBroker/Trans2QuikApi.hs
  6. 4
      stack.yaml

34
app/Main.hs
Unescape View File

@ -17,6 +17,7 @@ import ATrade.QuoteSource.Server
import ATrade.Broker.Server import ATrade.Broker.Server
import ATrade.Broker.Protocol import ATrade.Broker.Protocol
import Broker.PaperBroker import Broker.PaperBroker
import Broker.QuikBroker
import System.Log.Logger import System.Log.Logger
import System.Log.Handler.Simple import System.Log.Handler.Simple
@ -97,11 +98,6 @@ main = do
infoM "main" "Loading config" infoM "main" "Loading config"
config <- readConfig "quik-connector.config.json" config <- readConfig "quik-connector.config.json"
api <- runExceptT $ loadQuikApi "C:\\Program Files\\Info\\Trans2Quik.dll"
case api of
Left err -> print err
Right a -> infoM "main" "Quik API DLL loaded"
infoM "main" "Config loaded" infoM "main" "Config loaded"
chan <- newBoundedChan 1000 chan <- newBoundedChan 1000
infoM "main" "Starting data import server" infoM "main" "Starting data import server"
@ -110,18 +106,22 @@ main = do
(forkId, c1, c2) <- forkBoundedChan 1000 chan (forkId, c1, c2) <- forkBoundedChan 1000 chan
broker <- mkPaperBroker c1 1000000 ["demo"] broker <- mkPaperBroker c1 1000000 ["demo"]
withContext (\ctx -> eitherBrokerQ <- runExceptT $ mkQuikBroker "C:\\Program Files (x86)\\Info\\Trans2Quik.dll" "C:\\Program Files (x86)\\Info" ["<ACCOUNT>"]
bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\qsServer -> do case eitherBrokerQ of
bracket (startBrokerServer [broker] ctx (T.pack $ brokerserverEndpoint config)) stopBrokerServer (\broServer -> do Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg
void initGUI Right brokerQ ->
window <- windowNew withContext (\ctx ->
window `on` deleteEvent $ do bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config)) stopQuoteSourceServer (\qsServer -> do
liftIO mainQuit bracket (startBrokerServer [broker, brokerQ] ctx (T.pack $ brokerserverEndpoint config)) stopBrokerServer (\broServer -> do
return False void initGUI
widgetShowAll window window <- windowNew
mainGUI) window `on` deleteEvent $ do
infoM "main" "BRS down") liftIO mainQuit
) return False
widgetShowAll window
mainGUI)
infoM "main" "BRS down")
)
killThread forkId killThread forkId
infoM "main" "Main thread done" infoM "main" "Main thread done"

4
quik-connector.cabal
Unescape View File

@ -19,6 +19,7 @@ library
, QuoteSource.TableParser , QuoteSource.TableParser
, QuoteSource.TableParsers.AllParamsTableParser , QuoteSource.TableParsers.AllParamsTableParser
, Broker.PaperBroker , Broker.PaperBroker
, Broker.QuikBroker
, Broker.QuikBroker.Trans2QuikApi , Broker.QuikBroker.Trans2QuikApi
ghc-options: -Wincomplete-patterns ghc-options: -Wincomplete-patterns
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
@ -47,6 +48,9 @@ library
, libatrade , libatrade
, deepseq , deepseq
, errors , errors
, split
, bimap
, safe
default-language: Haskell2010 default-language: Haskell2010
extra-libraries: "user32" extra-libraries: "user32"
other-modules: System.Win32.XlParser other-modules: System.Win32.XlParser

9
src/Broker/PaperBroker.hs
Unescape View File

@ -35,7 +35,6 @@ data PaperBrokerState = PaperBrokerState {
tickMap :: M.HashMap TickMapKey Tick, tickMap :: M.HashMap TickMapKey Tick,
orders :: M.HashMap OrderId Order, orders :: M.HashMap OrderId Order,
cash :: ! Decimal, cash :: ! Decimal,
orderIdCounter :: OrderId,
notificationCallback :: Maybe (Notification -> IO ()) notificationCallback :: Maybe (Notification -> IO ())
} }
@ -47,7 +46,6 @@ mkPaperBroker tickChan startCash accounts = do
tickMap = M.empty, tickMap = M.empty,
orders = M.empty, orders = M.empty,
cash = startCash, cash = startCash,
orderIdCounter = 1,
notificationCallback = Nothing } notificationCallback = Nothing }
tid <- forkIO $ brokerThread state tid <- forkIO $ brokerThread state
@ -69,12 +67,6 @@ brokerThread state = do
where where
makeKey !tick = TickMapKey (security $! tick) (datatype tick) makeKey !tick = TickMapKey (security $! tick) (datatype tick)
nextOrderId :: IORef PaperBrokerState -> IO OrderId
nextOrderId state = do
id <- orderIdCounter <$> readIORef state
modifyIORef state (\s -> s { orderIdCounter = id + 1 } )
return id
pbSetNotificationCallback :: IORef PaperBrokerState -> Maybe (Notification -> IO ()) -> IO() pbSetNotificationCallback :: IORef PaperBrokerState -> Maybe (Notification -> IO ()) -> IO()
pbSetNotificationCallback state callback = modifyIORef state (\s -> s { notificationCallback = callback } ) pbSetNotificationCallback state callback = modifyIORef state (\s -> s { notificationCallback = callback } )
@ -101,6 +93,7 @@ pbSubmitOrder state order = do
atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , cash = cash s - tradeVolume}, ()) ) atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , cash = cash s - tradeVolume}, ()) )
ts <- getCurrentTime ts <- getCurrentTime
maybeCall notificationCallback state $ TradeNotification $ mkTrade tick order ts maybeCall notificationCallback state $ TradeNotification $ mkTrade tick order ts
maybeCall notificationCallback state $ OrderNotification (orderId order) Executed
submitLimitOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order submitLimitOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order
submitStopOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order submitStopOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order

205
src/Broker/QuikBroker.hs
Unescape View File

@ -0,0 +1,205 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
module Broker.QuikBroker (
mkQuikBroker
) where
import ATrade.Types
import ATrade.Broker.Protocol
import ATrade.Broker.Server
import Broker.QuikBroker.Trans2QuikApi hiding (tradeAccount)
import Data.Decimal
import Data.IORef
import Data.List.Split
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Bimap as BM
import qualified Data.Text as T
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
import System.Log.Logger
import Safe
type QuikOrderId = Integer
data QuikBrokerState = QuikBrokerState {
notificationCallback :: Maybe (Notification -> IO ()),
quik :: IORef Quik,
orderMap :: M.Map OrderId Order,
orderIdMap :: BM.Bimap QuikOrderId OrderId,
trans2orderid :: M.Map Integer Order,
transIdCounter :: Integer
}
nextTransId state = atomicModifyIORef' state (\s -> (s { transIdCounter = transIdCounter s + 1 }, transIdCounter s))
maybeCall proj state arg = do
cb <- proj <$> readIORef state
case cb of
Just callback -> callback arg
Nothing -> return ()
mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> ExceptT T.Text IO BrokerInterface
mkQuikBroker dllPath quikPath accs = do
q <- mkQuik dllPath quikPath
state <- liftIO $ newIORef QuikBrokerState {
notificationCallback = Nothing,
quik = q,
orderMap = M.empty,
orderIdMap = BM.empty,
trans2orderid = M.empty,
transIdCounter = 1
}
setCallbacks q (qbTransactionCallback state) (qbOrderCallback state) (qbTradeCallback state)
return BrokerInterface {
accounts = accs,
setNotificationCallback = qbSetNotificationCallback state,
submitOrder = qbSubmitOrder state,
cancelOrder = qbCancelOrder state,
stopBroker = qbStopBroker state
}
qbSetNotificationCallback state maybecb = atomicModifyIORef' state (\s -> (s {
notificationCallback = maybecb }, ()))
qbSubmitOrder state order = do
q <- quik <$> readIORef state
transId <- nextTransId state
atomicModifyIORef' state (\s -> (s {
trans2orderid = M.insert transId order (trans2orderid s) }, ()))
case makeTransactionString transId order of
Just transStr -> do
rc <- quikSendTransaction q transStr
case rc of
Left errmsg -> warningM "Quik" $ "Unable to send transaction: " ++ T.unpack errmsg
Right _ -> debugM "Quik" $ "Order submitted: " ++ show order
Nothing -> warningM "Quik" $ "Unable to compose transaction string: " ++ show order
qbCancelOrder state orderid = do
q <- quik <$> readIORef state
transId <- nextTransId state
idMap <- orderIdMap <$> readIORef state
orders <- orderMap <$> readIORef state
case (BM.lookupR orderid idMap, M.lookup orderid orders) of
(Just quikOrderId, Just order) -> case makeCancelTransactionString transId order quikOrderId of
Just transString -> do
rc <- quikSendTransaction q transString
case rc of
Left errmsg -> warningM "Quik" ("Unable to send transaction: " ++ T.unpack errmsg) >> return False
Right _ -> debugM "Quik" ("Order cancelled: " ++ show orderid) >> return True
Nothing -> warningM "Quik" ("Unable to compose transaction string: " ++ show orderid) >> return False
_ -> warningM "Quik" ("Got request to cancel unknown order: " ++ show orderid) >> return False
qbStopBroker state = return ()
makeTransactionString transId order =
case (classcode, seccode) of
(Just cCode, Just sCode) -> Just $
"ACCOUNT=" ++ T.unpack (orderAccountId order) ++ ";" ++
"TYPE=" ++ orderTypeCode ++ ";" ++
"TRANS_ID=" ++ show transId ++ ";" ++
"CLASSCODE=" ++ cCode ++ ";" ++
"SECCODE=" ++ sCode ++ ";" ++
"ACTION=NEW_ORDER;OPERATION=" ++ operationCode ++ ";" ++
"PRICE=" ++ price ++ ";" ++
"QUANTITY=" ++ show (orderQuantity order) ++ ";"
_ -> Nothing
where
orderTypeCode = case orderPrice order of
Market -> "M"
Limit _ -> "L"
_ -> "X"
operationCode = case orderOperation order of
Buy -> "B"
Sell -> "S"
classcode = headMay . splitOn "#" . T.unpack $ orderSecurity order
seccode = (`atMay` 1) . splitOn "#" . T.unpack $ orderSecurity order
price = case orderPrice order of
Market -> "0"
Limit p -> L.dropWhileEnd (== '.') . L.dropWhileEnd (== '0') . show $ p
_ -> "0"
makeCancelTransactionString transId order orderId =
case (classcode, seccode) of
(Just cCode, Just sCode) -> Just $
"TRANS_ID=" ++ show transId ++ ";" ++
"CLASSCODE=" ++ cCode ++ ";" ++
"SECCODE=" ++ sCode ++ ";" ++
"ACTION=KILL_ORDER;ORDER_KEY=" ++ show orderId ++ ";"
_ -> Nothing
where
classcode = headMay . splitOn "#" . T.unpack $ orderSecurity order
seccode = (`atMay` 1) . splitOn "#" . T.unpack $ orderSecurity order
qbTransactionCallback state success transactionId orderNum = do
t2oid <- trans2orderid <$> readIORef state
case M.lookup transactionId t2oid of
Just order -> do
atomicModifyIORef' state (\s -> (s { trans2orderid = M.delete transactionId t2oid }, ()) )
newOrder <- if success
then registerOrder orderNum $ order { orderState = Unsubmitted }
else registerOrder orderNum $ order { orderState = Rejected }
maybeCall notificationCallback state (OrderNotification (orderId newOrder) (orderState newOrder))
Nothing -> return ()
where
registerOrder quikOrderId order = atomicModifyIORef' state (\s ->
(s { orderIdMap = BM.insert quikOrderId (orderId order) (orderIdMap s),
orderMap = M.insert (orderId order) order (orderMap s) }, order) )
qbOrderCallback state quikorder = do
orders <- orderMap <$> readIORef state
idMap <- orderIdMap <$> readIORef state
debugM "Quik" $ "Order: " ++ show quikorder
case BM.lookup (qoOrderId quikorder) idMap >>= flip M.lookup orders of
Just order -> do
updatedOrder <- if | qoStatus quikorder /= 1 && qoStatus quikorder /= 2 ->
if qoBalance quikorder == 0
then fullyExecuted order
else partiallyExecuted order (orderExecutedQuantity order - qoBalance quikorder)
| qoStatus quikorder == 1 ->
submitted order
| qoStatus quikorder == 2 ->
cancelled order
maybeCall notificationCallback state (OrderNotification (orderId updatedOrder) (orderState updatedOrder))
Nothing -> warningM "Quik" $ "Unknown order: state callback called: " ++ show quikorder
where
updateOrder :: Order -> IO Order
updateOrder updatedOrder =
atomicModifyIORef' state (\s -> (s { orderMap = M.insert (orderId updatedOrder) updatedOrder (orderMap s)}, updatedOrder))
fullyExecuted order = updateOrder $ order { orderState = Executed, orderExecutedQuantity = orderQuantity order }
partiallyExecuted order quan = updateOrder $ order { orderState = PartiallyExecuted, orderExecutedQuantity = quan }
submitted order = updateOrder $ order { orderState = Submitted }
cancelled order = updateOrder $ order { orderState = Cancelled }
qbTradeCallback state quiktrade = do
orders <- orderMap <$> readIORef state
idMap <- orderIdMap <$> readIORef state
debugM "Quik" $ "Trade: " ++ show quiktrade
case BM.lookup (qtOrderId quiktrade) idMap >>= flip M.lookup orders of
Just order -> maybeCall notificationCallback state (TradeNotification $ tradeFor order)
Nothing -> warningM "Quik" $ "Incoming trade for unknown order: " ++ show quiktrade
where
tradeFor order = Trade {
tradeOrderId = orderId order,
tradePrice = realFracToDecimal 10 $ qtPrice quiktrade,
tradeQuantity = qtQuantity quiktrade,
tradeVolume = realFracToDecimal 10 $ qtVolume quiktrade,
tradeVolumeCurrency = T.pack $ qtVolumeCurrency quiktrade,
tradeOperation = if qtSell quiktrade then Sell else Buy,
tradeAccount = orderAccountId order,
tradeSecurity = orderSecurity order,
tradeTimestamp = qtTimestamp quiktrade,
tradeSignalId = orderSignalId order }

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

@ -2,13 +2,20 @@
module Broker.QuikBroker.Trans2QuikApi ( module Broker.QuikBroker.Trans2QuikApi (
Trans2QuikApi(..), Trans2QuikApi(..),
loadQuikApi loadQuikApi,
Quik(..),
setCallbacks,
mkQuik,
QuikOrder(..),
QuikTrade(..),
quikSendTransaction
) where ) where
import Foreign import Foreign
import Foreign.C.Types import Foreign.C.Types
import Foreign.C.String import Foreign.C.String
import Foreign.Marshal.Array import Foreign.Marshal.Array
import Control.Monad
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Error.Util import Control.Error.Util
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -16,256 +23,264 @@ import System.Win32.DLL
import System.Win32.Types import System.Win32.Types
import Control.Concurrent import Control.Concurrent
import Data.IORef import Data.IORef
import Data.Time.Clock
import Data.Time.Calendar
import Data.Ratio
import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
import System.Log.Logger
EcSuccess = 0
EcFailed = 1 ecSuccess = 0
EcQuikTerminalNotFound = 2 ecFailed = 1
EcDllVersionNotSupported = 3 ecQuikTerminalNotFound = 2
EcAlreadyConnectedToQuik = 4 ecDllVersionNotSupported = 3
EcWrongSyntax = 5 ecAlreadyConnectedToQuik = 4
EcQuikNotConnected = 6 ecWrongSyntax = 5
EcDllNotConnected = 7 ecQuikNotConnected = 6
EcQuikConnected = 8 ecDllNotConnected = 7
EcQuikDisconnected = 9 ecQuikConnected = 8
EcDllConnected = 10 ecQuikDisconnected = 9
EcDllDisconnected = 11 ecDllConnected = 10
EcMemoryAllocationError = 12 ecDllDisconnected = 11
EcWrongConnectionHandle = 13 ecMemoryAllocationError = 12
EcWrongInputParams = 14 ecWrongConnectionHandle = 13
ecWrongInputParams = 14
type ConnectF = LPCSTR -> Ptr LONG -> LPSTR -> DWORD -> IO LONG type ConnectF = LPCSTR -> Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkConnectFun :: FunPtr ConnectF -> ConnectF mkConnectFun :: FunPtr ConnectF -> ConnectF
type DisconnectF = Ptr LONG -> LPSTR -> DWORD -> IO LONG type DisconnectF = Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkDisconnectFun :: FunPtr DisconnectF -> DisconnectF mkDisconnectFun :: FunPtr DisconnectF -> DisconnectF
type IsQuikConnectedF = Ptr LONG -> LPSTR -> DWORD -> IO LONG type IsQuikConnectedF = Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkIsQuikConnectedFun :: FunPtr IsQuikConnectedF -> IsQuikConnectedF mkIsQuikConnectedFun :: FunPtr IsQuikConnectedF -> IsQuikConnectedF
type IsDllConnectedF = Ptr LONG -> LPSTR -> DWORD -> IO LONG type IsDllConnectedF = Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkIsDllConnectedFun :: FunPtr IsDllConnectedF -> IsDllConnectedF mkIsDllConnectedFun :: FunPtr IsDllConnectedF -> IsDllConnectedF
type SendSyncTransactionF = LPSTR -> Ptr LONG -> Ptr LONG -> Ptr CDouble -> LPSTR -> DWORD -> Ptr LONG -> LPSTR -> DWORD -> IO LONG type SendSyncTransactionF = LPSTR -> Ptr LONG -> Ptr LONG -> Ptr CDouble -> LPSTR -> DWORD -> Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkSendSyncTransactionFun :: FunPtr SendSyncTransactionF -> SendSyncTransactionF mkSendSyncTransactionFun :: FunPtr SendSyncTransactionF -> SendSyncTransactionF
type SendAsyncTransactionF = LPSTR -> Ptr LONG -> LPSTR -> DWORD -> IO LONG type SendAsyncTransactionF = LPSTR -> Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkSendAsyncTransactionFun :: FunPtr SendAsyncTransactionF -> SendAsyncTransactionF mkSendAsyncTransactionFun :: FunPtr SendAsyncTransactionF -> SendAsyncTransactionF
type ConnectionStatusCallback = LONG -> LONG -> LPSTR -> IO () type ConnectionStatusCallback = LONG -> LONG -> LPSTR -> IO ()
foreign import ccall "wrapper" foreign import stdcall "wrapper"
mkConnectionStatusCallback :: ConnectionStatusCallback -> IO (FunPtr ConnectionStatusCallback) mkConnectionStatusCallback :: ConnectionStatusCallback -> IO (FunPtr ConnectionStatusCallback)
type SetConnectionStatusCallbackF = FunPtr ConnectionStatusCallback -> Ptr LONG -> LPSTR -> DWORD -> IO LONG type SetConnectionStatusCallbackF = FunPtr ConnectionStatusCallback -> Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkSetConnectionStatusCallbackFun :: FunPtr SetConnectionStatusCallbackF -> SetConnectionStatusCallbackF mkSetConnectionStatusCallbackFun :: FunPtr SetConnectionStatusCallbackF -> SetConnectionStatusCallbackF
type TransactionsReplyCallback = LONG -> LONG -> LONG -> DWORD -> CDouble -> LPSTR -> IO () type TransactionsReplyCallback = LONG -> LONG -> LONG -> DWORD -> CLLong -> LPSTR -> CIntPtr -> IO ()
foreign import ccall "wrapper" foreign import stdcall "wrapper"
mkTransactionsReplyCallback :: TransactionsReplyCallback -> IO (FunPtr TransactionsReplyCallback) mkTransactionsReplyCallback :: TransactionsReplyCallback -> IO (FunPtr TransactionsReplyCallback)
type SetTransactionsReplyCallbackF = FunPtr TransactionsReplyCallback -> Ptr LONG -> LPSTR -> DWORD -> IO LONG type SetTransactionsReplyCallbackF = FunPtr TransactionsReplyCallback -> Ptr LONG -> LPSTR -> DWORD -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkSetTransactionsReplyCallbackFun :: FunPtr SetTransactionsReplyCallbackF -> SetTransactionsReplyCallbackF mkSetTransactionsReplyCallbackFun :: FunPtr SetTransactionsReplyCallbackF -> SetTransactionsReplyCallbackF
type OrderStatusCallback = LONG -> DWORD -> CDouble -> LPSTR -> LPSTR -> CDouble -> LONG -> CDouble -> LONG -> LONG -> LONG -> IO () type OrderStatusCallback = LONG -> DWORD -> CLLong -> LPSTR -> LPSTR -> CDouble -> CLLong -> CDouble -> LONG -> LONG -> CIntPtr -> IO ()
foreign import ccall "wrapper" foreign import stdcall "wrapper"
mkOrderStatusCallback :: OrderStatusCallback -> IO (FunPtr OrderStatusCallback) mkOrderStatusCallback :: OrderStatusCallback -> IO (FunPtr OrderStatusCallback)
type TradeStatusCallback = LONG -> CDouble -> CDouble -> LPSTR -> LPSTR -> CDouble -> LONG -> CDouble -> LONG -> LONG -> IO () type TradeStatusCallback = LONG -> CLLong -> CLLong -> LPSTR -> LPSTR -> CDouble -> CLLong -> CDouble -> LONG -> CIntPtr -> IO ()
foreign import ccall "wrapper" foreign import stdcall "wrapper"
mkTradeStatusCallback :: TradeStatusCallback -> IO (FunPtr TradeStatusCallback) mkTradeStatusCallback :: TradeStatusCallback -> IO (FunPtr TradeStatusCallback)
type SubscribeOrdersF = LPSTR -> LPSTR -> IO LONG type SubscribeOrdersF = LPSTR -> LPSTR -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkSubscribeOrdersFun :: FunPtr SubscribeOrdersF -> SubscribeOrdersF mkSubscribeOrdersFun :: FunPtr SubscribeOrdersF -> SubscribeOrdersF
type SubscribeTradesF = LPSTR -> LPSTR -> IO LONG type SubscribeTradesF = LPSTR -> LPSTR -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkSubscribeTradesFun :: FunPtr SubscribeTradesF -> SubscribeTradesF mkSubscribeTradesFun :: FunPtr SubscribeTradesF -> SubscribeTradesF
type StartOrdersF = FunPtr OrderStatusCallback -> IO () type StartOrdersF = FunPtr OrderStatusCallback -> IO ()
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkStartOrdersFun :: FunPtr StartOrdersF -> StartOrdersF mkStartOrdersFun :: FunPtr StartOrdersF -> StartOrdersF
type StartTradesF = FunPtr TradeStatusCallback -> IO () type StartTradesF = FunPtr TradeStatusCallback -> IO ()
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkStartTradesFun :: FunPtr StartTradesF -> StartTradesF mkStartTradesFun :: FunPtr StartTradesF -> StartTradesF
type UnsubscribeOrdersF = IO LONG type UnsubscribeOrdersF = IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkUnsubscribeOrdersFun :: FunPtr UnsubscribeOrdersF -> UnsubscribeOrdersF mkUnsubscribeOrdersFun :: FunPtr UnsubscribeOrdersF -> UnsubscribeOrdersF
type UnsubscribeTradesF = IO LONG type UnsubscribeTradesF = IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkUnsubscribeTradesFun :: FunPtr UnsubscribeTradesF -> UnsubscribeTradesF mkUnsubscribeTradesFun :: FunPtr UnsubscribeTradesF -> UnsubscribeTradesF
-- Order requests -- Order requests
type OrderQtyF = LONG -> IO LONG type OrderQtyF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderQtyFun :: FunPtr OrderQtyF -> OrderQtyF mkOrderQtyFun :: FunPtr OrderQtyF -> OrderQtyF
type OrderDateF = LONG -> IO LONG type OrderDateF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderDateFun :: FunPtr OrderDateF -> OrderDateF mkOrderDateFun :: FunPtr OrderDateF -> OrderDateF
type OrderTimeF = LONG -> IO LONG type OrderTimeF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderTimeFun :: FunPtr OrderTimeF -> OrderTimeF mkOrderTimeFun :: FunPtr OrderTimeF -> OrderTimeF
type OrderActivationTimeF = LONG -> IO LONG type OrderActivationTimeF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderActivationTimeFun :: FunPtr OrderActivationTimeF -> OrderActivationTimeF mkOrderActivationTimeFun :: FunPtr OrderActivationTimeF -> OrderActivationTimeF
type OrderWithdrawTimeF = LONG -> IO LONG type OrderWithdrawTimeF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderWithdrawTimeFun :: FunPtr OrderWithdrawTimeF -> OrderWithdrawTimeF mkOrderWithdrawTimeFun :: FunPtr OrderWithdrawTimeF -> OrderWithdrawTimeF
type OrderExpiryF = LONG -> IO LONG type OrderExpiryF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderExpiryFun :: FunPtr OrderExpiryF -> OrderExpiryF mkOrderExpiryFun :: FunPtr OrderExpiryF -> OrderExpiryF
type OrderAccruedIntF = LONG -> IO CDouble type OrderAccruedIntF = LONG -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderAccruedIntFun :: FunPtr OrderAccruedIntF -> OrderAccruedIntF mkOrderAccruedIntFun :: FunPtr OrderAccruedIntF -> OrderAccruedIntF
type OrderYieldF = LONG -> IO CDouble type OrderYieldF = LONG -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderYieldFun :: FunPtr OrderYieldF -> OrderYieldF mkOrderYieldFun :: FunPtr OrderYieldF -> OrderYieldF
type OrderUserIdF = LONG -> IO LPSTR type OrderUserIdF = LONG -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderUserIdFun :: FunPtr OrderUserIdF -> OrderUserIdF mkOrderUserIdFun :: FunPtr OrderUserIdF -> OrderUserIdF
type OrderUidF = LONG -> IO LONG type OrderUidF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderUidFun :: FunPtr OrderUidF -> OrderUidF mkOrderUidFun :: FunPtr OrderUidF -> OrderUidF
type OrderAccountF = LONG -> IO LPSTR type OrderAccountF = LONG -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderAccountFun :: FunPtr OrderAccountF -> OrderAccountF mkOrderAccountFun :: FunPtr OrderAccountF -> OrderAccountF
type OrderBrokerRefF = LONG -> IO LPSTR type OrderBrokerRefF = LONG -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderBrokerRefFun :: FunPtr OrderBrokerRefF -> OrderBrokerRefF mkOrderBrokerRefFun :: FunPtr OrderBrokerRefF -> OrderBrokerRefF
type OrderClientCodeF = LONG -> IO LPSTR type OrderClientCodeF = LONG -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderClientCodeFun :: FunPtr OrderClientCodeF -> OrderClientCodeF mkOrderClientCodeFun :: FunPtr OrderClientCodeF -> OrderClientCodeF
type OrderFirmIdF = LONG -> IO LPSTR type OrderFirmIdF = LONG -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderFirmIdFun :: FunPtr OrderFirmIdF -> OrderFirmIdF mkOrderFirmIdFun :: FunPtr OrderFirmIdF -> OrderFirmIdF
type OrderVisibleQtyF = LONG -> IO LONG type OrderVisibleQtyF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderVisibleQtyFun :: FunPtr OrderVisibleQtyF -> OrderVisibleQtyF mkOrderVisibleQtyFun :: FunPtr OrderVisibleQtyF -> OrderVisibleQtyF
type OrderPeriodF = LONG -> IO LONG type OrderPeriodF = LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderPeriodFun :: FunPtr OrderPeriodF -> OrderPeriodF mkOrderPeriodFun :: FunPtr OrderPeriodF -> OrderPeriodF
type OrderDateTimeF = LONG -> LONG -> IO LONG type OrderDateTimeF = LONG -> LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkOrderDateTimeFun :: FunPtr OrderDateTimeF -> OrderDateTimeF mkOrderDateTimeFun :: FunPtr OrderDateTimeF -> OrderDateTimeF
-- Trade requests -- Trade requests
type TradeDateF = LONG -> IO LONG type TradeDateF = CIntPtr -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeDateFun :: FunPtr TradeDateF -> TradeDateF mkTradeDateFun :: FunPtr TradeDateF -> TradeDateF
type TradeSettleDateF = LONG -> IO LONG type TradeSettleDateF = CIntPtr -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeSettleDateFun :: FunPtr TradeSettleDateF -> TradeSettleDateF mkTradeSettleDateFun :: FunPtr TradeSettleDateF -> TradeSettleDateF
type TradeTimeF = LONG -> IO LONG type TradeTimeF = CIntPtr -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeTimeFun :: FunPtr TradeTimeF -> TradeTimeF mkTradeTimeFun :: FunPtr TradeTimeF -> TradeTimeF
type TradeIsMarginalF = LONG -> IO LONG type TradeIsMarginalF = CIntPtr -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeIsMarginalFun :: FunPtr TradeIsMarginalF -> TradeIsMarginalF mkTradeIsMarginalFun :: FunPtr TradeIsMarginalF -> TradeIsMarginalF
type TradeCurrencyF = LONG -> IO LPSTR type TradeCurrencyF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeCurrencyFun :: FunPtr TradeCurrencyF -> TradeCurrencyF mkTradeCurrencyFun :: FunPtr TradeCurrencyF -> TradeCurrencyF
type TradeSettleCurrencyF = LONG -> IO LPSTR type TradeSettleCurrencyF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeSettleCurrencyFun :: FunPtr TradeSettleCurrencyF -> TradeSettleCurrencyF mkTradeSettleCurrencyFun :: FunPtr TradeSettleCurrencyF -> TradeSettleCurrencyF
type TradeSettleCodeF = LONG -> IO LPSTR type TradeSettleCodeF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeSettleCodeFun :: FunPtr TradeSettleCodeF -> TradeSettleCodeF mkTradeSettleCodeFun :: FunPtr TradeSettleCodeF -> TradeSettleCodeF
type TradeAccruedIntF = LONG -> IO CDouble type TradeAccruedIntF = CIntPtr -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeAccruedIntFun :: FunPtr TradeAccruedIntF -> TradeAccruedIntF mkTradeAccruedIntFun :: FunPtr TradeAccruedIntF -> TradeAccruedIntF
type TradeYieldF = LONG -> IO CDouble type TradeYieldF = CIntPtr -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeYieldFun :: FunPtr TradeYieldF -> TradeYieldF mkTradeYieldFun :: FunPtr TradeYieldF -> TradeYieldF
type TradeUserIdF = LONG -> IO LPSTR type TradeUserIdF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeUserIdFun :: FunPtr TradeUserIdF -> TradeUserIdF mkTradeUserIdFun :: FunPtr TradeUserIdF -> TradeUserIdF
type TradeAccountF = LONG -> IO LPSTR type TradeAccountF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeAccountFun :: FunPtr TradeAccountF -> TradeAccountF mkTradeAccountFun :: FunPtr TradeAccountF -> TradeAccountF
type TradeBrokerRefF = LONG -> IO LPSTR type TradeBrokerRefF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeBrokerRefFun :: FunPtr TradeBrokerRefF -> TradeBrokerRefF mkTradeBrokerRefFun :: FunPtr TradeBrokerRefF -> TradeBrokerRefF
type TradeClientCodeF = LONG -> IO LPSTR type TradeClientCodeF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeClientCodeFun :: FunPtr TradeClientCodeF -> TradeClientCodeF mkTradeClientCodeFun :: FunPtr TradeClientCodeF -> TradeClientCodeF
type TradeFirmIdF = LONG -> IO LPSTR type TradeFirmIdF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeFirmIdFun :: FunPtr TradeFirmIdF -> TradeFirmIdF mkTradeFirmIdFun :: FunPtr TradeFirmIdF -> TradeFirmIdF
type TradePartnerFirmIdF = LONG -> IO LPSTR type TradePartnerFirmIdF = CIntPtr -> IO LPSTR
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradePartnerFirmIdFun :: FunPtr TradePartnerFirmIdF -> TradePartnerFirmIdF mkTradePartnerFirmIdFun :: FunPtr TradePartnerFirmIdF -> TradePartnerFirmIdF
type TradeTsCommissionF = LONG -> IO CDouble type TradeTsCommissionF = CIntPtr -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeTsCommissionFun :: FunPtr TradeTsCommissionF -> TradeTsCommissionF mkTradeTsCommissionFun :: FunPtr TradeTsCommissionF -> TradeTsCommissionF
type TradeClearingCenterCommissionF = LONG -> IO CDouble type TradeClearingCenterCommissionF = CIntPtr -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeClearingCenterCommissionFun :: FunPtr TradeClearingCenterCommissionF -> TradeClearingCenterCommissionF mkTradeClearingCenterCommissionFun :: FunPtr TradeClearingCenterCommissionF -> TradeClearingCenterCommissionF
type TradeExchangeCommissionF = LONG -> IO CDouble type TradeExchangeCommissionF = CIntPtr -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeExchangeCommissionFun :: FunPtr TradeExchangeCommissionF -> TradeExchangeCommissionF mkTradeExchangeCommissionFun :: FunPtr TradeExchangeCommissionF -> TradeExchangeCommissionF
type TradeTradingSystemCommissionF = LONG -> IO CDouble type TradeTradingSystemCommissionF = CIntPtr -> IO CDouble
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeTradingSystemCommissionFun :: FunPtr TradeTradingSystemCommissionF -> TradeTradingSystemCommissionF mkTradeTradingSystemCommissionFun :: FunPtr TradeTradingSystemCommissionF -> TradeTradingSystemCommissionF
type TradePeriodF = LONG -> IO LONG type TradePeriodF = CIntPtr -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradePeriodFun :: FunPtr TradePeriodF -> TradePeriodF mkTradePeriodFun :: FunPtr TradePeriodF -> TradePeriodF
type TradeDateTimeF = LONG -> IO LONG type TradeDateTimeF = CIntPtr -> LONG -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeDateTimeFun :: FunPtr TradeDateTimeF -> TradeDateTimeF mkTradeDateTimeFun :: FunPtr TradeDateTimeF -> TradeDateTimeF
type TradeKindF = LONG -> IO LONG type TradeKindF = CIntPtr -> IO LONG
foreign import ccall "dynamic" foreign import stdcall "dynamic"
mkTradeKindFun :: FunPtr TradeKindF -> TradeKindF mkTradeKindFun :: FunPtr TradeKindF -> TradeKindF
toDouble :: CDouble -> Double
toDouble (CDouble x) = x
data Trans2QuikApi = Trans2QuikApi { data Trans2QuikApi = Trans2QuikApi {
connect :: ConnectF, connect :: ConnectF,
disconnect :: DisconnectF, disconnect :: DisconnectF,
@ -321,6 +336,32 @@ data Trans2QuikApi = Trans2QuikApi {
dllHandle :: HMODULE dllHandle :: HMODULE
} }
data QuikOrder = QuikOrder {
qoTransId :: Integer,
qoOrderId :: Integer,
qoTicker :: String,
qoPrice :: Double,
qoBalance :: Integer,
qoSell :: Bool,
qoStatus :: Int
} deriving (Show, Eq, Ord)
data QuikTrade = QuikTrade {
qtOrderId :: Integer,
qtTicker :: String,
qtPrice :: Double,
qtQuantity :: Integer,
qtSell :: Bool,
qtVolume :: Double,
qtVolumeCurrency :: String,
qtTimestamp :: UTCTime
} deriving (Show, Eq)
-- Success -> transaction id -> order num -> IO ()
type HlTransactionCallback = Bool -> Integer -> Integer -> IO ()
type HlOrderCallback = QuikOrder -> IO ()
type HlTradeCallback = QuikTrade -> IO ()
data Quik = Quik { data Quik = Quik {
quikApi :: Trans2QuikApi, quikApi :: Trans2QuikApi,
@ -329,104 +370,237 @@ data Quik = Quik {
orderCallback :: FunPtr OrderStatusCallback, orderCallback :: FunPtr OrderStatusCallback,
tradeCallback :: FunPtr TradeStatusCallback, tradeCallback :: FunPtr TradeStatusCallback,
hlTransactionCallback :: Maybe HlTransactionCallback,
hlOrderCallback :: Maybe HlOrderCallback,
hlTradeCallback :: Maybe HlTradeCallback,
connected :: Bool, connected :: Bool,
watchdogTid :: ThreadId watchdogTid :: ThreadId,
handledTrades :: S.Set CLLong,
handledOrders :: S.Set QuikOrder
} }
mkQuik :: FilePath -> FilePath -> ConnectionStatusCallback -> TransactionsReplyCallback -> OrderStatusCallback -> TradeStatusCallback -> ExceptT T.Text IO (IORef Quik) quikSendTransaction :: IORef Quik -> String -> IO (Either T.Text ())
mkQuik dllpath quikpath conncb transcb orcb tradecb = do quikSendTransaction state transactionString = do
api <- quikApi <$> readIORef state
alloca (\errcode ->
allocaBytes 1024 (\errorMsg ->
withCString transactionString (\trs -> do
rc <- sendAsyncTransaction api trs errcode errorMsg 1024
if rc /= ecSuccess
then do
msg <- peekCString errorMsg
return $ Left $ "Unable to submit transaction: " `T.append` T.pack msg
else return $ Right ())))
setCallbacks :: IORef Quik -> HlTransactionCallback -> HlOrderCallback -> HlTradeCallback -> ExceptT T.Text IO ()
setCallbacks quik transCb orCb tradeCb =
liftIO $ atomicModifyIORef' quik (\s ->
( s { hlTransactionCallback = Just transCb,
hlOrderCallback = Just orCb,
hlTradeCallback = Just tradeCb }, ()))
mkQuik :: FilePath -> FilePath -> ExceptT T.Text IO (IORef Quik)
mkQuik dllpath quikpath = do
api <- loadQuikApi dllpath api <- loadQuikApi dllpath
conncb' <- liftIO (mkConnectionStatusCallback conncb) liftIO $ debugM "Quik" "Dll loaded"
transcb' <- liftIO (mkTransactionsReplyCallback transcb)
orcb' <- liftIO (mkOrderStatusCallback orcb)
tradecb' <- liftIO (mkTradeStatusCallback tradecb)
myTid <- liftIO myThreadId myTid <- liftIO myThreadId
state <- liftIO $ newIORef Quik { quikApi = api, state <- liftIO $ newIORef Quik { quikApi = api,
connectionCallback = conncb', connected = False,
watchdogTid = myTid,
hlTransactionCallback = Nothing,
hlOrderCallback = Nothing,
hlTradeCallback = Nothing,
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))
liftIO (atomicModifyIORef' state (\s -> (s { connectionCallback = conncb',
transactionCallback = transcb', transactionCallback = transcb',
orderCallback = orcb', orderCallback = orcb',
tradeCallback = tradecb', tradeCallback = tradecb' }, ())))
connected = False,
watchdogTid = myTid }
tid <- liftIO (forkIO $ watchdog quikpath state) tid <- liftIO (forkIO $ watchdog quikpath state)
liftIO $ atomicModifyIORef' (\s -> s { watchdogTid = tid }) liftIO $ atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ()))
liftIO $ debugM "Quik" "mkQuik done"
return state return state
defaultConnectionCb :: IORef Quik -> LONG -> LONG -> LPSTR -> IO ()
defaultConnectionCb state event errorCode infoMessage
| event == ecDllConnected || event == ecQuikConnected = infoM "Quik" "Quik connected" >> atomicModifyIORef' state (\s -> (s { connected = True }, ()) )
| event == ecQuikDisconnected = infoM "Quik" "Quik disconnected" >> atomicModifyIORef' state (\s -> (s { connected = False }, ()) )
| otherwise = debugM "Quik" $ "Connection event: " ++ show event
defaultTransactionReplyCb :: IORef Quik -> LONG -> LONG -> LONG -> DWORD -> CLLong -> LPSTR -> CIntPtr -> IO ()
defaultTransactionReplyCb state transactionResult errorCode replyCode transId orderNum replyMessage replyDesc = do
maybecb <- hlTransactionCallback <$> readIORef state
case maybecb of
Just cb -> cb (transactionResult == ecSuccess) (toInteger transId) (toInteger orderNum)
Nothing -> return ()
defaultOrderCb :: IORef Quik -> LONG -> DWORD -> CLLong -> LPSTR -> LPSTR -> CDouble -> CLLong -> CDouble -> LONG -> LONG -> CIntPtr -> IO ()
defaultOrderCb state mode transId dnumber classCode secCode price balance value sell status desc = do
orders <- handledOrders <$> readIORef state
when (mode == 0) $ do
maybecb <- hlOrderCallback <$> readIORef state
ssec <- peekCString secCode
sclass <- peekCString classCode
let order = mkOrder sclass ssec
when (order `S.notMember` orders) $ do
atomicModifyIORef' state (\s -> (s { handledOrders = S.insert order (handledOrders s) }, ()))
case maybecb of
Just cb -> cb order
Nothing -> return ()
where
mkOrder :: String -> String -> QuikOrder
mkOrder sclass ssec = QuikOrder {
qoTransId = toInteger transId,
qoOrderId = toInteger dnumber,
qoTicker = sclass ++ "#" ++ ssec,
qoPrice = toDouble price,
qoBalance = toInteger balance,
qoSell = sell == 1,
qoStatus = fromIntegral status
}
defaultTradeCb :: IORef Quik -> LONG -> CLLong -> CLLong -> LPSTR -> LPSTR -> CDouble -> CLLong -> CDouble -> LONG -> CIntPtr -> IO ()
defaultTradeCb state mode dnumber orderNum classCode secCode price qty value sell desc = do
trades <- handledTrades <$> readIORef state
when (mode == 0 && dnumber `S.notMember` trades) $ do
atomicModifyIORef' state (\s -> (s { handledTrades = S.insert dnumber (handledTrades s) }, ()))
api <- quikApi <$> readIORef state
maybecb <- hlTradeCallback <$> readIORef state
case maybecb of
Just cb -> do
ssec <- peekCString secCode
sclass <- peekCString classCode
ymd <- toInteger <$> tradeDateTime api desc 0
hms <- toInteger <$> tradeDateTime api desc 1
us <- toInteger <$> tradeDateTime api desc 2
currency <- tradeCurrency api desc >>= peekCString
cb (trade ssec sclass ymd hms us currency)
Nothing -> return ()
where
trade ssec sclass ymd hms us currency = QuikTrade {
qtOrderId = toInteger orderNum,
qtTicker = sclass ++ "#" ++ ssec,
qtPrice = toDouble price,
qtQuantity = toInteger qty,
qtSell = sell == 1,
qtVolume = toDouble value,
qtVolumeCurrency = currency,
qtTimestamp = mkTimestamp ymd hms us
}
mkTimestamp ymd hms us = UTCTime (fromGregorian y mon d) (fromInteger (h * 3600 + m * 60 + s) + fromRational (us % 1000000))
where
y = ymd `div` 10000
mon = fromEnum $ (ymd `mod` 10000) `div` 100
d = fromEnum $ ymd `mod` 100
h = hms `div` 10000
m = (hms `mod` 10000) `div` 100
s = hms `mod` 100
watchdog :: FilePath -> IORef Quik -> IO () watchdog :: FilePath -> IORef Quik -> IO ()
watchdog quikpath state = do watchdog quikpath state = do
api <- quikApi <$> readIORef state api <- quikApi <$> readIORef state
conncb <- connectionCallback <$> readIORef state conncb <- connectionCallback <$> readIORef state
transcb <- transactionCallback <$> readIORef state
orcb <- orderCallback <$> readIORef state
tradecb <- tradeCallback <$> readIORef state
alloca (\errorCode -> alloca (\errorCode ->
allocaBytes 1024 (\errorMsg -> do allocaBytes 1024 (\errorMsg -> do
err <- setConnectionStatusCallback api $ conncb errorCode errorMsg 1024 err <- setConnectionStatusCallback api conncb errorCode errorMsg 1024
if err /= EcSuccess if err /= ecSuccess
then warningM "Quik.Watchdog" $ "Error: " ++ show err then warningM "Quik.Watchdog" $ "Error: " ++ show err
else forever $ do else forever $ do
conn <- connected <$> readIORef state conn <- connected <$> readIORef state
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
when (err /= EcSuccess) $ warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err) if err /= ecSuccess
then warningM "Quik.Watchdog" $ "Unable to connect: " ++ show err
else withCString "" (\emptyStr -> do
(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)
return ()))
threadDelay 5000000)) threadDelay 5000000))
throwIfErr :: IO LONG -> ExceptT T.Text IO ()
throwIfErr action = do
rc <- liftIO action
if rc /= ecSuccess
then throwE "Error"
else return ()
loadQuikApi :: FilePath -> ExceptT T.Text IO Trans2QuikApi loadQuikApi :: FilePath -> ExceptT T.Text 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"
connectPtr <- mkConnectFun <$> tryLoad dll "_TRANS2QUIK_CONNECT@16" connectPtr <- mkConnectFun <$> tryLoad dll "TRANS2QUIK_CONNECT"
disconnectPtr <- mkDisconnectFun <$> tryLoad dll "_TRANS2QUIK_DISCONNECT@12" disconnectPtr <- mkDisconnectFun <$> tryLoad dll "TRANS2QUIK_DISCONNECT"
isQuikConnectedPtr <- mkIsQuikConnectedFun <$> tryLoad dll "_TRANS2QUIK_IS_QUIK_CONNECTED@12" isQuikConnectedPtr <- mkIsQuikConnectedFun <$> tryLoad dll "TRANS2QUIK_IS_QUIK_CONNECTED"
isDllConnectedPtr <- mkIsDllConnectedFun <$> tryLoad dll "_TRANS2QUIK_IS_DLL_CONNECTED@12" isDllConnectedPtr <- mkIsDllConnectedFun <$> tryLoad dll "TRANS2QUIK_IS_DLL_CONNECTED"
sendSyncTransactionPtr <- mkSendSyncTransactionFun <$> tryLoad dll "_TRANS2QUIK_SEND_SYNC_TRANSACTION@36" sendSyncTransactionPtr <- mkSendSyncTransactionFun <$> tryLoad dll "TRANS2QUIK_SEND_SYNC_TRANSACTION"
sendAsyncTransactionPtr <- mkSendAsyncTransactionFun <$> tryLoad dll "_TRANS2QUIK_SEND_ASYNC_TRANSACTION@16" sendAsyncTransactionPtr <- mkSendAsyncTransactionFun <$> tryLoad dll "TRANS2QUIK_SEND_ASYNC_TRANSACTION"
setConnectionStatusCallbackPtr <- mkSetConnectionStatusCallbackFun <$> tryLoad dll "_TRANS2QUIK_SET_CONNECTION_STATUS_CALLBACK@16" setConnectionStatusCallbackPtr <- mkSetConnectionStatusCallbackFun <$> tryLoad dll "TRANS2QUIK_SET_CONNECTION_STATUS_CALLBACK"
setTransactionsReplyCallbackPtr <- mkSetTransactionsReplyCallbackFun <$> tryLoad dll "_TRANS2QUIK_SET_TRANSACTIONS_REPLY_CALLBACK@16" setTransactionsReplyCallbackPtr <- mkSetTransactionsReplyCallbackFun <$> tryLoad dll "TRANS2QUIK_SET_TRANSACTIONS_REPLY_CALLBACK"
subscribeOrdersPtr <- mkSubscribeOrdersFun <$> tryLoad dll "_TRANS2QUIK_SUBSCRIBE_ORDERS@8" subscribeOrdersPtr <- mkSubscribeOrdersFun <$> tryLoad dll "TRANS2QUIK_SUBSCRIBE_ORDERS"
subscribeTradesPtr <- mkSubscribeTradesFun <$> tryLoad dll "_TRANS2QUIK_SUBSCRIBE_TRADES@8" subscribeTradesPtr <- mkSubscribeTradesFun <$> tryLoad dll "TRANS2QUIK_SUBSCRIBE_TRADES"
startOrdersPtr <- mkStartOrdersFun <$> tryLoad dll "_TRANS2QUIK_START_ORDERS@4" startOrdersPtr <- mkStartOrdersFun <$> tryLoad dll "TRANS2QUIK_START_ORDERS"
startTradesPtr <- mkStartTradesFun <$> tryLoad dll "_TRANS2QUIK_START_TRADES@4" startTradesPtr <- mkStartTradesFun <$> tryLoad dll "TRANS2QUIK_START_TRADES"
unsubscribeOrdersPtr <- mkUnsubscribeOrdersFun <$> tryLoad dll "_TRANS2QUIK_UNSUBSCRIBE_ORDERS@0" unsubscribeOrdersPtr <- mkUnsubscribeOrdersFun <$> tryLoad dll "TRANS2QUIK_UNSUBSCRIBE_ORDERS"
unsubscribeTradesPtr <- mkUnsubscribeTradesFun <$> tryLoad dll "_TRANS2QUIK_UNSUBSCRIBE_TRADES@0" unsubscribeTradesPtr <- mkUnsubscribeTradesFun <$> tryLoad dll "TRANS2QUIK_UNSUBSCRIBE_TRADES"
orderQtyPtr <- mkOrderQtyFun <$> tryLoad dll "_TRANS2QUIK_ORDER_QTY@4" orderQtyPtr <- mkOrderQtyFun <$> tryLoad dll "TRANS2QUIK_ORDER_QTY"
orderDatePtr <- mkOrderDateFun <$> tryLoad dll "_TRANS2QUIK_ORDER_DATE@4" orderDatePtr <- mkOrderDateFun <$> tryLoad dll "TRANS2QUIK_ORDER_DATE"
orderTimePtr <- mkOrderTimeFun <$> tryLoad dll "_TRANS2QUIK_ORDER_TIME@4" orderTimePtr <- mkOrderTimeFun <$> tryLoad dll "TRANS2QUIK_ORDER_TIME"
orderActivationTimePtr <- mkOrderActivationTimeFun <$> tryLoad dll "_TRANS2QUIK_ORDER_ACTIVATION_TIME@4" orderActivationTimePtr <- mkOrderActivationTimeFun <$> tryLoad dll "TRANS2QUIK_ORDER_ACTIVATION_TIME"
orderWithdrawTimePtr <- mkOrderWithdrawTimeFun <$> tryLoad dll "_TRANS2QUIK_ORDER_WITHDRAW_TIME@4" orderWithdrawTimePtr <- mkOrderWithdrawTimeFun <$> tryLoad dll "TRANS2QUIK_ORDER_WITHDRAW_TIME"
orderExpiryPtr <- mkOrderExpiryFun <$> tryLoad dll "_TRANS2QUIK_ORDER_EXPIRY@4" orderExpiryPtr <- mkOrderExpiryFun <$> tryLoad dll "TRANS2QUIK_ORDER_EXPIRY"
orderAccruedIntPtr <- mkOrderAccruedIntFun <$> tryLoad dll "_TRANS2QUIK_ORDER_ACCRUED_INT@4" orderAccruedIntPtr <- mkOrderAccruedIntFun <$> tryLoad dll "TRANS2QUIK_ORDER_ACCRUED_INT"
orderYieldPtr <- mkOrderYieldFun <$> tryLoad dll "_TRANS2QUIK_ORDER_YIELD@4" orderYieldPtr <- mkOrderYieldFun <$> tryLoad dll "TRANS2QUIK_ORDER_YIELD"
orderUserIdPtr <- mkOrderUserIdFun <$> tryLoad dll "_TRANS2QUIK_ORDER_USERID@4" orderUserIdPtr <- mkOrderUserIdFun <$> tryLoad dll "TRANS2QUIK_ORDER_USERID"
orderUidPtr <- mkOrderUidFun <$> tryLoad dll "_TRANS2QUIK_ORDER_UID@4" orderUidPtr <- mkOrderUidFun <$> tryLoad dll "TRANS2QUIK_ORDER_UID"
orderAccountPtr <- mkOrderAccountFun <$> tryLoad dll "_TRANS2QUIK_ORDER_ACCOUNT@4" orderAccountPtr <- mkOrderAccountFun <$> tryLoad dll "TRANS2QUIK_ORDER_ACCOUNT"
orderBrokerRefPtr <- mkOrderBrokerRefFun <$> tryLoad dll "_TRANS2QUIK_ORDER_BROKERREF@4" orderBrokerRefPtr <- mkOrderBrokerRefFun <$> tryLoad dll "TRANS2QUIK_ORDER_BROKERREF"
orderClientCodePtr <- mkOrderClientCodeFun <$> tryLoad dll "_TRANS2QUIK_ORDER_CLIENT_CODE@4" orderClientCodePtr <- mkOrderClientCodeFun <$> tryLoad dll "TRANS2QUIK_ORDER_CLIENT_CODE"
orderFirmIdPtr <- mkOrderFirmIdFun <$> tryLoad dll "_TRANS2QUIK_ORDER_FIRMID@4" orderFirmIdPtr <- mkOrderFirmIdFun <$> tryLoad dll "TRANS2QUIK_ORDER_FIRMID"
orderVisibleQtyPtr <- mkOrderVisibleQtyFun <$> tryLoad dll "_TRANS2QUIK_ORDER_VISIBLE_QTY@4" orderVisibleQtyPtr <- mkOrderVisibleQtyFun <$> tryLoad dll "TRANS2QUIK_ORDER_VISIBLE_QTY"
orderPeriodPtr <- mkOrderPeriodFun <$> tryLoad dll "_TRANS2QUIK_ORDER_PERIOD@4" orderPeriodPtr <- mkOrderPeriodFun <$> tryLoad dll "TRANS2QUIK_ORDER_PERIOD"
orderDateTimePtr <- mkOrderDateTimeFun <$> tryLoad dll "_TRANS2QUIK_ORDER_DATE_TIME@8" orderDateTimePtr <- mkOrderDateTimeFun <$> tryLoad dll "TRANS2QUIK_ORDER_DATE_TIME"
tradeDatePtr <- mkTradeDateFun <$> tryLoad dll "_TRANS2QUIK_TRADE_DATE@4" tradeDatePtr <- mkTradeDateFun <$> tryLoad dll "TRANS2QUIK_TRADE_DATE"
tradeSettleDatePtr <- mkTradeSettleDateFun <$> tryLoad dll "_TRANS2QUIK_TRADE_SETTLE_DATE@4" tradeSettleDatePtr <- mkTradeSettleDateFun <$> tryLoad dll "TRANS2QUIK_TRADE_SETTLE_DATE"
tradeTimePtr <- mkTradeTimeFun <$> tryLoad dll "_TRANS2QUIK_TRADE_TIME@4" tradeTimePtr <- mkTradeTimeFun <$> tryLoad dll "TRANS2QUIK_TRADE_TIME"
tradeIsMarginalPtr <- mkTradeIsMarginalFun <$> tryLoad dll "_TRANS2QUIK_TRADE_IS_MARGINAL@4" tradeIsMarginalPtr <- mkTradeIsMarginalFun <$> tryLoad dll "TRANS2QUIK_TRADE_IS_MARGINAL"
tradeCurrencyPtr <- mkTradeCurrencyFun <$> tryLoad dll "_TRANS2QUIK_TRADE_CURRENCY@4" tradeCurrencyPtr <- mkTradeCurrencyFun <$> tryLoad dll "TRANS2QUIK_TRADE_CURRENCY"
tradeSettleCurrencyPtr <- mkTradeSettleCurrencyFun <$> tryLoad dll "_TRANS2QUIK_TRADE_SETTLE_CURRENCY@4" tradeSettleCurrencyPtr <- mkTradeSettleCurrencyFun <$> tryLoad dll "TRANS2QUIK_TRADE_SETTLE_CURRENCY"
tradeSettleCodePtr <- mkTradeSettleCodeFun <$> tryLoad dll "_TRANS2QUIK_TRADE_SETTLE_CODE@4" tradeSettleCodePtr <- mkTradeSettleCodeFun <$> tryLoad dll "TRANS2QUIK_TRADE_SETTLE_CODE"
tradeAccruedIntPtr <- mkTradeAccruedIntFun <$> tryLoad dll "_TRANS2QUIK_TRADE_ACCRUED_INT@4" tradeAccruedIntPtr <- mkTradeAccruedIntFun <$> tryLoad dll "TRANS2QUIK_TRADE_ACCRUED_INT"
tradeYieldPtr <- mkTradeYieldFun <$> tryLoad dll "_TRANS2QUIK_TRADE_YIELD@4" tradeYieldPtr <- mkTradeYieldFun <$> tryLoad dll "TRANS2QUIK_TRADE_YIELD"
tradeUserIdPtr <- mkTradeUserIdFun <$> tryLoad dll "_TRANS2QUIK_TRADE_USERID@4" tradeUserIdPtr <- mkTradeUserIdFun <$> tryLoad dll "TRANS2QUIK_TRADE_USERID"
tradeAccountPtr <- mkTradeAccountFun <$> tryLoad dll "_TRANS2QUIK_TRADE_ACCOUNT@4" tradeAccountPtr <- mkTradeAccountFun <$> tryLoad dll "TRANS2QUIK_TRADE_ACCOUNT"
tradeBrokerRefPtr <- mkTradeBrokerRefFun <$> tryLoad dll "_TRANS2QUIK_TRADE_BROKERREF@4" tradeBrokerRefPtr <- mkTradeBrokerRefFun <$> tryLoad dll "TRANS2QUIK_TRADE_BROKERREF"
tradeClientCodePtr <- mkTradeClientCodeFun <$> tryLoad dll "_TRANS2QUIK_TRADE_CLIENT_CODE@4" tradeClientCodePtr <- mkTradeClientCodeFun <$> tryLoad dll "TRANS2QUIK_TRADE_CLIENT_CODE"
tradeTsCommissionPtr <- mkTradeTsCommissionFun <$> tryLoad dll "_TRANS2QUIK_TRADE_TS_COMMISSION@4" tradeTsCommissionPtr <- mkTradeTsCommissionFun <$> tryLoad dll "TRANS2QUIK_TRADE_TS_COMMISSION"
tradePeriodPtr <- mkTradePeriodFun <$> tryLoad dll "_TRANS2QUIK_TRADE_PERIOD@4" tradePeriodPtr <- mkTradePeriodFun <$> tryLoad dll "TRANS2QUIK_TRADE_PERIOD"
tradeDateTimePtr <- mkTradeDateTimeFun <$> tryLoad dll "_TRANS2QUIK_TRADE_DATE_TIME@8" tradeDateTimePtr <- mkTradeDateTimeFun <$> tryLoad dll "TRANS2QUIK_TRADE_DATE_TIME"
tradeKindPtr <- mkTradeKindFun <$> tryLoad dll "_TRANS2QUIK_TRADE_KIND@4" tradeKindPtr <- mkTradeKindFun <$> tryLoad dll "TRANS2QUIK_TRADE_KIND"
return Trans2QuikApi { return Trans2QuikApi {
connect = connectPtr, connect = connectPtr,
@ -497,4 +671,3 @@ loadQuikApi path = do
getProcAddress' dll proc = withCAString proc (c_GetProcAddress dll . castPtr) getProcAddress' dll proc = withCAString proc (c_GetProcAddress dll . castPtr)

4
stack.yaml
Unescape View File

@ -56,8 +56,8 @@ extra-package-dbs: []
# require-stack-version: ">=1.2" # require-stack-version: ">=1.2"
# #
# Override the architecture used by stack, especially useful on Windows # Override the architecture used by stack, especially useful on Windows
arch: i386 # arch: i386
# arch: x86_64 arch: x86_64
# #
# Extra directories used by stack for building # Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir] # extra-include-dirs: [/path/to/dir]

Write Preview
Loading…
Cancel
Save