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

Various tweaks

master
Denis Tereshkin 9 years ago
parent
8b40ef2e43
commit
b766eeae61
7 changed files with 67 additions and 67 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. 30
      app/Main.hs
  2. 41
      src/Broker/PaperBroker.hs
  3. 6
      src/Broker/QuikBroker.hs
  4. 6
      src/Broker/QuikBroker/Trans2QuikApi.hs
  5. 8
      src/Network/Telegram.hs
  6. 8
      src/QuoteSource/DataImport.hs
  7. 35
      src/System/Win32/DDE.hs

30
app/Main.hs
Unescape View File

@ -4,15 +4,13 @@ module Main where
import System.IO import System.IO
import QuoteSource.DataImport import QuoteSource.DataImport
import Control.Concurrent hiding (readChan) import Control.Concurrent hiding (readChan, writeChan)
import Control.Monad import Control.Monad
import Control.Exception import Control.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.IORef import Data.IORef
import Graphics.UI.Gtk hiding (Action, backspace) import Graphics.UI.Gtk hiding (Action, backspace)
import Control.Concurrent.BoundedChan import Control.Concurrent.BoundedChan
import Control.Concurrent.STM
import Control.Concurrent.STM.TBQueue
import ATrade.Types import ATrade.Types
import QuoteSource.TableParsers.AllParamsTableParser import QuoteSource.TableParsers.AllParamsTableParser
import QuoteSource.TableParser import QuoteSource.TableParser
@ -40,6 +38,9 @@ import Control.Monad.Trans.Except
import Broker.QuikBroker.Trans2QuikApi import Broker.QuikBroker.Trans2QuikApi
import Network.Telegram import Network.Telegram
import Network.Connection
import Network.HTTP.Client
import Network.HTTP.Client.TLS
data TableConfig = TableConfig { data TableConfig = TableConfig {
parserId :: String, parserId :: String,
@ -104,15 +105,14 @@ parseConfig = withObject "object" $ \obj -> do
tableName = tn, tableName = tn,
tableParams = params } tableParams = params }
forkBoundedChan :: Int -> TBQueue Tick -> IO (ThreadId, TBQueue Tick, TBQueue QuoteSourceServerData) forkBoundedChan :: Int -> BoundedChan Tick -> IO (ThreadId, BoundedChan Tick, BoundedChan QuoteSourceServerData)
forkBoundedChan size source = do forkBoundedChan size source = do
sink <- atomically $ newTBQueue size sink <- newBoundedChan size
sinkQss <- atomically $ newTBQueue size sinkQss <- newBoundedChan size
tid <- forkIO $ forever $ do tid <- forkIO $ forever $ do
v <- atomically $ readTBQueue source v <- readChan source
atomically $ do writeChan sink v
writeTBQueue sink v writeChan sinkQss (QSSTick v)
writeTBQueue sinkQss (QSSTick v)
return (tid, sink, sinkQss) return (tid, sink, sinkQss)
@ -133,15 +133,17 @@ main = do
config <- readConfig "quik-connector.config.json" config <- readConfig "quik-connector.config.json"
infoM "main" "Config loaded" infoM "main" "Config loaded"
chan <- atomically $ newTBQueue 1000 chan <- newBoundedChan 10000
infoM "main" "Starting data import server" infoM "main" "Starting data import server"
dis <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade" dis <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade"
(forkId, c1, c2) <- forkBoundedChan 1000 chan (forkId, c1, c2) <- forkBoundedChan 10000 chan
broker <- mkPaperBroker c1 1000000 ["demo"] broker <- mkPaperBroker c1 1000000 ["demo"]
eitherBrokerQ <- runExceptT $ mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config) (Just (telegramToken config, telegramChatId config)) man <- newManager (mkManagerSettings (TLSSettingsSimple { settingDisableCertificateValidation = True, settingDisableSession = False, settingUseServerName = False }) Nothing)
tgCtx <- mkTelegramContext (telegramToken config) infoM "main" "Http manager created"
eitherBrokerQ <- runExceptT $ mkQuikBroker man (dllPath config) (quikPath config) (quikAccounts config) (Just (telegramToken config, telegramChatId config))
tgCtx <- mkTelegramContext man (telegramToken config)
sendMessage tgCtx (telegramChatId config) "Goldmine-Quik connector started" sendMessage tgCtx (telegramChatId config) "Goldmine-Quik connector started"
case eitherBrokerQ of case eitherBrokerQ of
Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg Left errmsg -> warningM "main" $ "Can't load quik broker: " ++ T.unpack errmsg

41
src/Broker/PaperBroker.hs
Unescape View File

@ -10,8 +10,6 @@ module Broker.PaperBroker (
import Control.DeepSeq import Control.DeepSeq
import Data.Hashable import Data.Hashable
import Data.Bits import Data.Bits
import Control.Concurrent.STM
import Control.Concurrent.STM.TBQueue
import ATrade.Types import ATrade.Types
import Data.IORef import Data.IORef
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
@ -21,6 +19,7 @@ import ATrade.Broker.Server
import Data.Time.Clock import Data.Time.Clock
import Data.Decimal import Data.Decimal
import Control.Monad import Control.Monad
import Control.Concurrent.BoundedChan
import Control.Concurrent hiding (readChan) import Control.Concurrent hiding (readChan)
import System.Log.Logger import System.Log.Logger
@ -38,9 +37,9 @@ data PaperBrokerState = PaperBrokerState {
notificationCallback :: Maybe (Notification -> IO ()) notificationCallback :: Maybe (Notification -> IO ())
} }
mkPaperBroker :: TBQueue Tick -> Decimal -> [T.Text] -> IO BrokerInterface mkPaperBroker :: BoundedChan Tick -> Decimal -> [T.Text] -> IO BrokerInterface
mkPaperBroker tickChan startCash accounts = do mkPaperBroker tickChan startCash accounts = do
state <- atomically $ newTVar PaperBrokerState { state <- newIORef PaperBrokerState {
pbTid = Nothing, pbTid = Nothing,
tickMap = M.empty, tickMap = M.empty,
orders = M.empty, orders = M.empty,
@ -48,7 +47,7 @@ mkPaperBroker tickChan startCash accounts = do
notificationCallback = Nothing } notificationCallback = Nothing }
tid <- forkIO $ brokerThread tickChan state tid <- forkIO $ brokerThread tickChan state
atomically $ modifyTVar' state (\s -> s { pbTid = Just tid }) atomicModifyIORef' state (\s -> (s { pbTid = Just tid }, ()))
return BrokerInterface { return BrokerInterface {
accounts = accounts, accounts = accounts,
@ -57,18 +56,18 @@ mkPaperBroker tickChan startCash accounts = do
cancelOrder = pbCancelOrder state, cancelOrder = pbCancelOrder state,
stopBroker = pbDestroyBroker state } stopBroker = pbDestroyBroker state }
brokerThread :: TBQueue Tick -> TVar PaperBrokerState -> IO () brokerThread :: BoundedChan Tick -> IORef PaperBrokerState -> IO ()
brokerThread chan state = forever $ atomically $ do brokerThread chan state = forever $ do
tick <- readTBQueue chan tick <- readChan chan
modifyTVar' state (\s -> s { tickMap = M.insert (makeKey tick) tick $! tickMap s }) atomicModifyIORef' state (\s -> (s { tickMap = M.insert (makeKey tick) tick $! tickMap s }, ()))
where where
makeKey !tick = TickMapKey (security $! tick) (datatype tick) makeKey !tick = TickMapKey (security $! tick) (datatype tick)
pbSetNotificationCallback :: TVar PaperBrokerState -> Maybe (Notification -> IO ()) -> IO() pbSetNotificationCallback :: IORef PaperBrokerState -> Maybe (Notification -> IO ()) -> IO()
pbSetNotificationCallback state callback = atomically $ modifyTVar' state (\s -> s { notificationCallback = callback } ) pbSetNotificationCallback state callback = atomicModifyIORef' state (\s -> (s { notificationCallback = callback }, ()) )
pbSubmitOrder :: TVar PaperBrokerState -> Order -> IO () pbSubmitOrder :: IORef PaperBrokerState -> Order -> IO ()
pbSubmitOrder state order = do pbSubmitOrder state order = do
infoM "PaperBroker" $ "Submitted order: " ++ show order infoM "PaperBroker" $ "Submitted order: " ++ show order
case orderPrice order of case orderPrice order of
@ -79,14 +78,14 @@ pbSubmitOrder state order = do
where where
executeMarketOrder state order = do executeMarketOrder state order = do
tm <- atomically $ tickMap <$> readTVar state tm <- tickMap <$> readIORef state
case M.lookup key tm of case M.lookup key tm of
Nothing -> let newOrder = order { orderState = OrderError } in Nothing -> let newOrder = order { orderState = OrderError } in
atomically $ modifyTVar' state (\s -> s { orders = M.insert (orderId order) newOrder $ orders s }) atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ()))
Just tick -> let newOrder = order { orderState = Executed } Just tick -> let newOrder = order { orderState = Executed }
tradeVolume = (realFracToDecimal 10 (fromIntegral $ orderQuantity order) * value tick) in do tradeVolume = (realFracToDecimal 10 (fromIntegral $ orderQuantity order) * value tick) in do
atomically $ modifyTVar' 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}, ()))
debugM "PaperBroker" $ "Executed: " ++ show newOrder debugM "PaperBroker" $ "Executed: " ++ show newOrder
ts <- getCurrentTime ts <- getCurrentTime
maybeCall notificationCallback state $ TradeNotification $ mkTrade tick order ts maybeCall notificationCallback state $ TradeNotification $ mkTrade tick order ts
@ -102,7 +101,7 @@ pbSubmitOrder state order = do
key = TickMapKey (orderSecurity order) (orderDatatype order) key = TickMapKey (orderSecurity order) (orderDatatype order)
maybeCall proj state arg = do maybeCall proj state arg = do
cb <- atomically $ proj <$> readTVar state cb <- proj <$> readIORef state
case cb of case cb of
Just callback -> callback arg Just callback -> callback arg
Nothing -> return () Nothing -> return ()
@ -121,16 +120,16 @@ pbSubmitOrder state order = do
tradeSignalId = orderSignalId order } tradeSignalId = orderSignalId order }
pbCancelOrder :: TVar PaperBrokerState -> OrderId -> IO Bool pbCancelOrder :: IORef PaperBrokerState -> OrderId -> IO Bool
pbCancelOrder state order = undefined pbCancelOrder state order = undefined
pbDestroyBroker :: TVar PaperBrokerState -> IO () pbDestroyBroker :: IORef PaperBrokerState -> IO ()
pbDestroyBroker state = do pbDestroyBroker state = do
maybeTid <- atomically $ pbTid <$> readTVar state maybeTid <- pbTid <$> readIORef state
case maybeTid of case maybeTid of
Just tid -> killThread tid Just tid -> killThread tid
Nothing -> return () Nothing -> return ()
pbGetOrder :: TVar PaperBrokerState -> OrderId -> IO (Maybe Order) pbGetOrder :: IORef PaperBrokerState -> OrderId -> IO (Maybe Order)
pbGetOrder state oid = atomically $ M.lookup oid . orders <$> readTVar state pbGetOrder state oid = M.lookup oid . orders <$> readIORef state

6
src/Broker/QuikBroker.hs
Unescape View File

@ -62,15 +62,15 @@ messageThread tgCtx chatId msgChan = forever $ do
Nothing -> threadDelay 500000 Nothing -> threadDelay 500000
mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> Maybe (T.Text, T.Text) -> ExceptT T.Text IO BrokerInterface mkQuikBroker :: Manager -> FilePath -> FilePath -> [T.Text] -> Maybe (T.Text, T.Text) -> ExceptT T.Text IO BrokerInterface
mkQuikBroker dllPath quikPath accs tgParams = do mkQuikBroker man dllPath quikPath accs tgParams = do
q <- mkQuik dllPath quikPath q <- mkQuik dllPath quikPath
msgChan <- liftIO $ newBoundedChan 100 msgChan <- liftIO $ newBoundedChan 100
msgTid <- liftIO $ case tgParams of msgTid <- liftIO $ case tgParams of
Nothing -> return Nothing Nothing -> return Nothing
Just (tgToken, chatId) -> do Just (tgToken, chatId) -> do
tgCtx <- mkTelegramContext tgToken tgCtx <- mkTelegramContext man tgToken
tid <- forkIO $ messageThread tgCtx chatId msgChan tid <- forkIO $ messageThread tgCtx chatId msgChan
return $ Just tid return $ Just tid

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

@ -429,7 +429,7 @@ mkQuik dllpath quikpath = do
orderCallback = orcb', orderCallback = orcb',
tradeCallback = tradecb' }, ()))) tradeCallback = tradecb' }, ())))
tid <- liftIO (forkIO $ watchdog quikpath state) tid <- liftIO (forkOS $ watchdog quikpath state)
liftIO $ atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ())) liftIO $ atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ()))
liftIO $ debugM "Quik" "mkQuik done" liftIO $ debugM "Quik" "mkQuik done"
return state return state
@ -522,7 +522,7 @@ watchdog quikpath state = do
tradecb <- tradeCallback <$> readIORef state tradecb <- tradeCallback <$> readIORef state
alloca (\errorCode -> alloca (\errorCode ->
allocaBytes 1024 (\errorMsg -> do allocaBytes 2048 (\errorMsg -> do
err <- setConnectionStatusCallback api conncb errorCode errorMsg 1024 err <- setConnectionStatusCallback api conncb errorCode errorMsg 1024
if err /= ecSuccess if err /= ecSuccess
@ -544,7 +544,7 @@ watchdog quikpath state = do
case res of case res of
Left err -> warningM "Quik.Watchdog" $ "Unable to set callbacks: " ++ show err Left err -> warningM "Quik.Watchdog" $ "Unable to set callbacks: " ++ show err
Right _ -> debugM "Quik.Watchdog" "Callbacks are set")) Right _ -> debugM "Quik.Watchdog" "Callbacks are set"))
threadDelay 5000000)) threadDelay 1000))
throwIfErr :: IO LONG -> ExceptT T.Text IO () throwIfErr :: IO LONG -> ExceptT T.Text IO ()
throwIfErr action = do throwIfErr action = do

8
src/Network/Telegram.hs
Unescape View File

@ -3,7 +3,8 @@
module Network.Telegram module Network.Telegram
( (
mkTelegramContext, mkTelegramContext,
sendMessage sendMessage,
Manager
) where ) where
import Control.Monad import Control.Monad
@ -22,9 +23,8 @@ data TelegramContext = TelegramContext {
httpMan :: Manager httpMan :: Manager
} }
mkTelegramContext :: T.Text -> IO TelegramContext mkTelegramContext :: Manager -> T.Text -> IO TelegramContext
mkTelegramContext token = do mkTelegramContext man token = do
man <- newManager (mkManagerSettings (TLSSettingsSimple { settingDisableCertificateValidation = True, settingDisableSession = False, settingUseServerName = False }) Nothing)
return TelegramContext { httpMan = man, tgToken = token } return TelegramContext { httpMan = man, tgToken = token }

8
src/QuoteSource/DataImport.hs
Unescape View File

@ -7,8 +7,6 @@ module QuoteSource.DataImport
) where ) where
import Control.Concurrent.BoundedChan import Control.Concurrent.BoundedChan
import Control.Concurrent.STM
import Control.Concurrent.STM.TBQueue
import Control.Monad.State.Strict import Control.Monad.State.Strict
import ATrade.Types import ATrade.Types
import Data.IORef import Data.IORef
@ -22,7 +20,7 @@ import qualified Data.Map as M
data ServerState = ServerState { data ServerState = ServerState {
appName :: String, appName :: String,
parsers :: IORef (M.Map String TableParserInstance), parsers :: IORef (M.Map String TableParserInstance),
tickChannel :: TBQueue Tick tickChannel :: BoundedChan Tick
} }
ddeCallback :: ServerState -> String -> (Int, Int, [XlData]) -> IO Bool ddeCallback :: ServerState -> String -> (Int, Int, [XlData]) -> IO Bool
@ -34,12 +32,12 @@ ddeCallback state topic table = do
let stateWithTimeHint = giveTimestampHint myParser timeHint let stateWithTimeHint = giveTimestampHint myParser timeHint
let (ticks, newState) = runState (parseXlTable table) stateWithTimeHint let (ticks, newState) = runState (parseXlTable table) stateWithTimeHint
modifyIORef' (parsers state) (\s -> newState `seq` s `seq` M.insert topic (MkTableParser newState) s) modifyIORef' (parsers state) (\s -> newState `seq` s `seq` M.insert topic (MkTableParser newState) s)
mapM_ (atomically . writeTBQueue (tickChannel state)) ticks mapM_ (writeChan (tickChannel state)) ticks
return True return True
_ -> return False _ -> return False
initDataImportServer :: [TableParserInstance] -> TBQueue Tick -> String -> IO (ServerState, IORef DdeState) initDataImportServer :: [TableParserInstance] -> BoundedChan Tick -> String -> IO (ServerState, IORef DdeState)
initDataImportServer parsers tickChan applicationName = do initDataImportServer parsers tickChan applicationName = do
parsers <- newIORef $ M.fromList $ map (\(MkTableParser p) -> (getTableId p, MkTableParser p)) parsers parsers <- newIORef $ M.fromList $ map (\(MkTableParser p) -> (getTableId p, MkTableParser p)) parsers
let s = ServerState { appName = applicationName, parsers = parsers, tickChannel = tickChan } let s = ServerState { appName = applicationName, parsers = parsers, tickChannel = tickChan }

35
src/System/Win32/DDE.hs
Unescape View File

@ -31,7 +31,7 @@ import Control.Monad
import Data.Bits import Data.Bits
import Data.Binary.Get import Data.Binary.Get
import Data.Typeable import Data.Typeable
import Data.ByteString hiding (map) import Data.ByteString hiding (map, putStrLn)
import Data.IORef import Data.IORef
import System.Win32.XlParser import System.Win32.XlParser
import System.Win32.DLL import System.Win32.DLL
@ -65,31 +65,31 @@ ddeCpWinAnsi = 1004
instance Exception DdeException instance Exception DdeException
foreign import WINDOWS_CCONV unsafe "windows.h DdeInitializeW" foreign import WINDOWS_CCONV "windows.h DdeInitializeW"
ddeInitialize :: LPDWORD -> FunPtr DdeCallback -> DWORD -> DWORD -> IO CUInt ddeInitialize :: LPDWORD -> FunPtr DdeCallback -> DWORD -> DWORD -> IO CUInt
foreign import WINDOWS_CCONV unsafe "windows.h DdeUninitialize" foreign import WINDOWS_CCONV "windows.h DdeUninitialize"
ddeUninitialize :: DWORD -> IO BOOL ddeUninitialize :: DWORD -> IO BOOL
foreign import WINDOWS_CCONV unsafe "windows.h DdeCreateStringHandleW" foreign import WINDOWS_CCONV "windows.h DdeCreateStringHandleW"
ddeCreateStringHandle :: DWORD -> LPSTR -> CInt -> IO HANDLE ddeCreateStringHandle :: DWORD -> LPSTR -> CInt -> IO HANDLE
foreign import WINDOWS_CCONV unsafe "windows.h DdeFreeStringHandleW" foreign import WINDOWS_CCONV "windows.h DdeFreeStringHandleW"
ddeFreeStringHandle :: DWORD -> LPSTR -> IO HANDLE ddeFreeStringHandle :: DWORD -> LPSTR -> IO HANDLE
foreign import WINDOWS_CCONV unsafe "windows.h DdeNameService" foreign import WINDOWS_CCONV "windows.h DdeNameService"
ddeNameService :: DWORD -> HANDLE -> HANDLE -> CInt -> IO HANDLE ddeNameService :: DWORD -> HANDLE -> HANDLE -> CInt -> IO HANDLE
foreign import WINDOWS_CCONV unsafe "windows.h DdeCmpStringHandles" foreign import WINDOWS_CCONV "windows.h DdeCmpStringHandles"
ddeCmpStringHandles :: HANDLE -> HANDLE -> IO CInt ddeCmpStringHandles :: HANDLE -> HANDLE -> IO CInt
foreign import WINDOWS_CCONV unsafe "windows.h DdeQueryStringW" foreign import WINDOWS_CCONV "windows.h DdeQueryStringW"
ddeQueryString :: DWORD -> HANDLE -> CString -> DWORD -> CInt -> IO DWORD ddeQueryString :: DWORD -> HANDLE -> CString -> DWORD -> CInt -> IO DWORD
foreign import WINDOWS_CCONV unsafe "windows.h DdeAccessData" foreign import WINDOWS_CCONV "windows.h DdeAccessData"
ddeAccessData :: HANDLE -> LPDWORD -> IO (Ptr CUChar) ddeAccessData :: HANDLE -> LPDWORD -> IO (Ptr CUChar)
foreign import WINDOWS_CCONV unsafe "windows.h DdeUnaccessData" foreign import WINDOWS_CCONV "windows.h DdeUnaccessData"
ddeUnaccessData :: HANDLE -> IO () ddeUnaccessData :: HANDLE -> IO ()
foreign import WINDOWS_CCONV "wrapper" foreign import WINDOWS_CCONV "wrapper"
@ -133,13 +133,14 @@ ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2
maybeTopic <- queryString myDdeState 256 hsz1 maybeTopic <- queryString myDdeState 256 hsz1
case maybeTopic of case maybeTopic of
Nothing -> return ddeResultFalse Nothing -> return ddeResultFalse
Just topic -> withDdeData hData (\xlData -> case runGetOrFail xlParser $ BL.fromStrict xlData of Just topic -> withDdeData hData (\xlData -> do
Left (_, _, errmsg) -> return ddeResultFalse case runGetOrFail xlParser $ BL.fromStrict xlData of
Right (_, _, table) -> do Left (_, _, errmsg) -> return ddeResultFalse
rc <- (dataCallback myDdeState) topic table Right (_, _, table) -> do
return $ if rc rc <- (dataCallback myDdeState) topic table
then ddeResultAck return $ if rc
else ddeResultFalse ) then ddeResultAck
else ddeResultFalse )
initializeDde :: String -> String -> DdeDataCallback -> IO (IORef DdeState) initializeDde :: String -> String -> DdeDataCallback -> IO (IORef DdeState)
initializeDde appName topic callback = alloca (\instancePtr -> do initializeDde appName topic callback = alloca (\instancePtr -> do

Write Preview
Loading…
Cancel
Save