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

Build against libatrade-0.12

master
Denis Tereshkin 4 years ago
parent
b2b91c8cea
commit
192b897e73
10 changed files with 338 additions and 259 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. 35
      app/Config.hs
  2. 159
      app/Main.hs
  3. 10
      quik-connector.cabal
  4. 85
      src/Broker/PaperBroker.hs
  5. 150
      src/Broker/QuikBroker.hs
  6. 116
      src/Broker/QuikBroker/Trans2QuikApi.hs
  7. 22
      src/QuoteSource/PipeReader.hs
  8. 3
      src/System/Win32/DDE.hs
  9. 3
      src/TickTable.hs
  10. 14
      stack.yaml

35
app/Config.hs
Unescape View File

@ -23,22 +23,23 @@ data TableConfig = TableConfig {
} deriving (Show) } deriving (Show)
data Config = Config { data Config = Config {
quotesourceEndpoint :: String, quotesourceEndpoint :: String,
qtisEndpoint :: String, qtisEndpoint :: String,
pipeReaderQsEndpoint :: Maybe String, pipeReaderQsEndpoint :: Maybe String,
tickPipePath :: Maybe String, tickPipePath :: Maybe String,
brokerserverEndpoint :: String, brokerserverEndpoint :: String,
whitelist :: [T.Text], brokerNotificationsEndpoint :: String,
blacklist :: [T.Text], whitelist :: [T.Text],
brokerServerCertPath :: Maybe FilePath, blacklist :: [T.Text],
brokerClientCertificateDir :: Maybe FilePath, brokerServerCertPath :: Maybe FilePath,
tables :: [TableConfig], brokerClientCertificateDir :: Maybe FilePath,
quikPath :: String, tables :: [TableConfig],
dllPath :: String, quikPath :: String,
quikAccounts :: [T.Text], dllPath :: String,
tradeSink :: T.Text, quikAccounts :: [T.Text],
tradeSink2 :: T.Text, tradeSink :: T.Text,
commissions :: [CommissionConfig] tradeSink2 :: T.Text,
commissions :: [CommissionConfig]
} deriving (Show) } deriving (Show)
readConfig :: String -> IO Config readConfig :: String -> IO Config
@ -55,6 +56,7 @@ parseConfig = withObject "object" $ \obj -> do
qsePipe <- obj .:? "quotesource-endpoint-pipe-reader" qsePipe <- obj .:? "quotesource-endpoint-pipe-reader"
pipePath <- obj .:? "pipe-reader-path" pipePath <- obj .:? "pipe-reader-path"
bse <- obj .: "brokerserver-endpoint" bse <- obj .: "brokerserver-endpoint"
bsne <- obj .: "brokerserver-notifications-endpoint"
whitelist' <- obj .:? "whitelist" .!= [] whitelist' <- obj .:? "whitelist" .!= []
blacklist' <- obj .:? "blacklist" .!= [] blacklist' <- obj .:? "blacklist" .!= []
serverCert <- obj .:? "broker_server_certificate" serverCert <- obj .:? "broker_server_certificate"
@ -73,6 +75,7 @@ parseConfig = withObject "object" $ \obj -> do
pipeReaderQsEndpoint = qsePipe, pipeReaderQsEndpoint = qsePipe,
tickPipePath = pipePath, tickPipePath = pipePath,
brokerserverEndpoint = bse, brokerserverEndpoint = bse,
brokerNotificationsEndpoint = bsne,
whitelist = whitelist', whitelist = whitelist',
blacklist = blacklist', blacklist = blacklist',
brokerServerCertPath = serverCert, brokerServerCertPath = serverCert,

159
app/Main.hs
Unescape View File

@ -14,8 +14,10 @@ import Control.Concurrent.BoundedChan
import Control.Error.Util import Control.Error.Util
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (MonadIO)
import Data.GI.Base import Data.GI.Base
import qualified GI.Gtk as Gtk import qualified GI.Gtk as Gtk
import Prelude hiding (log)
import QuoteSource.DataImport import QuoteSource.DataImport
import QuoteSource.PipeReader import QuoteSource.PipeReader
import QuoteSource.TableParser import QuoteSource.TableParser
@ -27,10 +29,6 @@ import Broker.PaperBroker
import Broker.QuikBroker import Broker.QuikBroker
import System.Directory import System.Directory
import System.Log.Formatter
import System.Log.Handler (setFormatter)
import System.Log.Handler.Simple
import System.Log.Logger
import System.Timeout import System.Timeout
import System.ZMQ4 import System.ZMQ4
import System.ZMQ4.ZAP import System.ZMQ4.ZAP
@ -41,6 +39,13 @@ import Data.Version
import ATrade (libatrade_gitrev, import ATrade (libatrade_gitrev,
libatrade_version) libatrade_version)
import ATrade.Logging (Message, Severity (Debug, Info, Warning),
fmtMessage,
logWith)
import Colog (LogAction,
logTextStdout,
(>$<))
import Colog.Actions (logTextHandle)
import Config import Config
import TickTable (mkTickTable) import TickTable (mkTickTable)
import Version import Version
@ -58,83 +63,87 @@ forkBoundedChan size sourceChan = do
return (tid, sink1, sink2, sinkQss) return (tid, sink1, sink2, sinkQss)
mkLogger :: (MonadIO m) => Handle -> LogAction m Message
initLogging :: IO () mkLogger h = fmtMessage >$< (logTextStdout <> logTextHandle h)
initLogging = do
handler <- streamHandler stderr DEBUG >>=
(\x -> return $
setFormatter x (simpleLogFormatter "$utcTime\t {$loggername} <$prio> -> $msg"))
fhandler <- fileHandler "quik-connector.log" DEBUG >>=
(\x -> return $
setFormatter x (simpleLogFormatter "$utcTime\t {$loggername} <$prio> -> $msg"))
hSetBuffering stderr LineBuffering
updateGlobalLogger rootLoggerName (setLevel DEBUG)
updateGlobalLogger rootLoggerName (setHandlers [handler, fhandler])
main :: IO () main :: IO ()
main = do main = do
initLogging withFile "quik-connector.log" AppendMode $ \logH -> do
infoM "main" $ "Starting quik-connector-" ++ T.unpack quikConnectorVersionText ++ "; libatrade-" ++ showVersion libatrade_version ++ "(" ++ libatrade_gitrev ++ ")" let logger = mkLogger logH
infoM "main" "Loading config" let log = (logWith logger)
config <- readConfig "quik-connector.config.json" log Info "main" $ "Starting quik-connector-" <>
quikConnectorVersionText <>
infoM "main" "Config loaded" "; libatrade-" <>
chan <- newBoundedChan 10000 (T.pack . showVersion) libatrade_version <>
infoM "main" "Starting data import server" "(" <>
_ <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade" T.pack libatrade_gitrev <>
")"
(forkId, c0, c1, c2) <- forkBoundedChan 10000 chan log Info "main" "Loading config"
config <- readConfig "quik-connector.config.json"
withContext (\ctx -> do
tickTable <- mkTickTable c0 ctx (T.pack $ qtisEndpoint config) log Info "main" "Config loaded"
brokerQ <- mkQuikBroker tickTable (dllPath config) (quikPath config) (quikAccounts config) (commissions config) chan <- newBoundedChan 10000
brokerP <- mkPaperBroker tickTable c1 1000000 ["demo"] (commissions config) log Info "main" "Starting data import server"
withZapHandler ctx (\zap -> do _ <- initDataImportServer [MkTableParser $ mkAllParamsTableParser "allparams"] chan "atrade"
zapSetWhitelist zap "global" $ whitelist config
zapSetBlacklist zap "global" $ blacklist config (forkId, c0, c1, c2) <- forkBoundedChan 10000 chan
case brokerClientCertificateDir config of withContext (\ctx -> do
Just certFile -> do tickTable <- mkTickTable c0 ctx (T.pack $ qtisEndpoint config)
certs <- loadCertificatesFromDirectory certFile brokerQ <- mkQuikBroker tickTable (dllPath config) (quikPath config) (quikAccounts config) (commissions config) logger
forM_ certs (\cert -> zapAddClientCertificate zap "global" cert) brokerP <- mkPaperBroker tickTable c1 1000000 ["demo"] (commissions config) logger
Nothing -> return () withZapHandler ctx (\zap -> do
zapSetWhitelist zap "global" $ whitelist config
serverCert <- case brokerServerCertPath config of zapSetBlacklist zap "global" $ blacklist config
Just certFile -> do
eitherCert <- loadCertificateFromFile certFile case brokerClientCertificateDir config of
case eitherCert of Just certFile -> do
Left errorMessage -> do certs <- loadCertificatesFromDirectory certFile
warningM "main" $ "Unable to load server certificate: " ++ errorMessage forM_ certs (\cert -> zapAddClientCertificate zap "global" cert)
return Nothing Nothing -> return ()
Right cert -> return $ Just cert
Nothing -> return Nothing serverCert <- case brokerServerCertPath config of
let serverParams = defaultServerSecurityParams { sspDomain = Just "global", Just certFile -> do
sspCertificate = serverCert } eitherCert <- loadCertificateFromFile certFile
case eitherCert of
bracket (forkIO $ pipeReaderThread ctx config c2) killThread (\_ -> do Left errorMessage -> do
withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do log Warning "main" $ "Unable to load server certificate: " <> T.pack errorMessage
withZMQTradeSink ctx (tradeSink2 config) (\zmqTradeSink2 -> do return Nothing
bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config) quoteSourceServerSecurityParams) stopQuoteSourceServer (\_ -> do Right cert -> return $ Just cert
bracket (startBrokerServer [brokerP, brokerQ] ctx (T.pack $ brokerserverEndpoint config) [zmqTradeSink2, zmqTradeSink] serverParams) stopBrokerServer (\_ -> do Nothing -> return Nothing
void $ Gtk.init Nothing let serverParams = defaultServerSecurityParams { sspDomain = Just "global",
window <- new Gtk.Window [ #title := "Quik connector" ] sspCertificate = serverCert }
void $ on window #destroy Gtk.mainQuit
#showAll window bracket (forkIO $ pipeReaderThread ctx config c2 logger) killThread (\_ -> do
Gtk.main) withZMQTradeSink ctx (tradeSink config) (\zmqTradeSink -> do
infoM "main" "BRS down") withZMQTradeSink ctx (tradeSink2 config) (\zmqTradeSink2 -> do
debugM "main" "QS done") bracket (startQuoteSourceServer c2 ctx (T.pack $ quotesourceEndpoint config) quoteSourceServerSecurityParams) stopQuoteSourceServer (\_ -> do
debugM "main" "TGTS done") bracket (startBrokerServer
debugM "main" "ZMQTS done") [brokerP, brokerQ]
debugM "main" "ZAP done")) ctx
void $ timeout 1000000 $ killThread forkId (T.pack $ brokerserverEndpoint config)
infoM "main" "Main thread done" (T.pack $ brokerNotificationsEndpoint config)
[zmqTradeSink2, zmqTradeSink]
serverParams
logger) stopBrokerServer (\_ -> do
void $ Gtk.init Nothing
window <- new Gtk.Window [ #title := "Quik connector" ]
void $ on window #destroy Gtk.mainQuit
#showAll window
Gtk.main)
log Info "main" "BRS down")
log Debug "main" "QS done")
log Debug "main" "TGTS done")
log Debug "main" "ZMQTS done")
log Debug "main" "ZAP done"))
void $ timeout 1000000 $ killThread forkId
log Info "main" "Main thread done"
where where
pipeReaderThread ctx config qsdataChan = pipeReaderThread ctx config qsdataChan logger =
case pipeReaderQsEndpoint config of case pipeReaderQsEndpoint config of
Just qsep -> do Just qsep -> do
infoM "main" $ "QS: " ++ qsep logWith logger Info "main" $ "QS: " <> T.pack qsep
bracket (startPipeReader ctx (T.pack qsep) qsdataChan) stopPipeReader (\_ -> forever $ threadDelay 1000000) bracket (startPipeReader ctx (T.pack qsep) qsdataChan logger) stopPipeReader (\_ -> forever $ threadDelay 1000000)
_ -> return () _ -> return ()
quoteSourceServerSecurityParams = defaultServerSecurityParams { sspDomain = Just "global" } quoteSourceServerSecurityParams = defaultServerSecurityParams { sspDomain = Just "global" }

10
quik-connector.cabal
Unescape View File

@ -42,14 +42,13 @@ library
, transformers , transformers
, datetime , datetime
, BoundedChan , BoundedChan
, hslogger
, zeromq4-haskell , zeromq4-haskell
, hashable , hashable
, unordered-containers , unordered-containers
, aeson , aeson
, cond , cond
, scientific , scientific
, libatrade >= 0.9 && < 0.10 , libatrade >= 0.12 && < 0.13
, deepseq , deepseq
, errors , errors
, split , split
@ -63,13 +62,15 @@ library
, http-client-tls , http-client-tls
, utf8-string , utf8-string
, connection , connection
, text-format
, monad-loops , monad-loops
, extra , extra
, incremental-parser , incremental-parser
, attoparsec , attoparsec
, safe-exceptions , safe-exceptions
, iconv , iconv
, th-printf
, co-log
, co-log-core
default-language: Haskell2010 default-language: Haskell2010
-- extra-libraries: "user32" -- extra-libraries: "user32"
other-modules: System.Win32.XlParser other-modules: System.Win32.XlParser
@ -86,7 +87,6 @@ executable quik-connector-exe
, haskell-gi-base , haskell-gi-base
, gi-gtk , gi-gtk
, BoundedChan , BoundedChan
, hslogger
, aeson , aeson
, bytestring , bytestring
, unordered-containers , unordered-containers
@ -106,6 +106,8 @@ executable quik-connector-exe
, safe-exceptions , safe-exceptions
, iconv , iconv
, th-printf , th-printf
, co-log
, co-log-core
default-language: Haskell2010 default-language: Haskell2010
other-modules: Config other-modules: Config
, Version , Version

85
src/Broker/PaperBroker.hs
Unescape View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Strict #-} {-# LANGUAGE Strict #-}
module Broker.PaperBroker ( module Broker.PaperBroker (
@ -6,10 +7,15 @@ module Broker.PaperBroker (
mkPaperBroker mkPaperBroker
) where ) where
import ATrade.Broker.Backend
import ATrade.Broker.Protocol import ATrade.Broker.Protocol
import ATrade.Broker.Server import ATrade.Broker.Server
import ATrade.Logging (Message, Severity (..),
logWith)
import ATrade.Quotes.QTIS import ATrade.Quotes.QTIS
import ATrade.Types import ATrade.Types
import Colog (LogAction)
import Commissions (CommissionConfig (..))
import Control.Concurrent hiding (readChan, writeChan) import Control.Concurrent hiding (readChan, writeChan)
import Control.Concurrent.BoundedChan import Control.Concurrent.BoundedChan
import Control.Monad import Control.Monad
@ -20,11 +26,10 @@ import qualified Data.List as L
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time.Clock import Data.Time.Clock
import System.Log.Logger import Language.Haskell.Printf (t)
import System.ZMQ4 import System.ZMQ4
import Commissions (CommissionConfig (..))
import TickTable (TickKey (..), TickTableH, import TickTable (TickKey (..), TickTableH,
getTick, getTickerInfo) getTick, getTickerInfo)
@ -33,7 +38,7 @@ data PaperBrokerState = PaperBrokerState {
tickTable :: TickTableH, tickTable :: TickTableH,
orders :: M.Map OrderId Order, orders :: M.Map OrderId Order,
cash :: !Price, cash :: !Price,
notificationCallback :: Maybe (Notification -> IO ()), notificationCallback :: Maybe (BrokerBackendNotification -> IO ()),
pendingOrders :: [Order], pendingOrders :: [Order],
fortsClassCodes :: [T.Text], fortsClassCodes :: [T.Text],
@ -45,14 +50,15 @@ data PaperBrokerState = PaperBrokerState {
postMarketStartTime :: DiffTime, postMarketStartTime :: DiffTime,
postMarketFixTime :: DiffTime, postMarketFixTime :: DiffTime,
postMarketCloseTime :: DiffTime, postMarketCloseTime :: DiffTime,
commissions :: [CommissionConfig] commissions :: [CommissionConfig],
logger :: LogAction IO Message
} }
hourMin :: Integer -> Integer -> DiffTime hourMin :: Integer -> Integer -> DiffTime
hourMin h m = fromIntegral $ h * 3600 + m * 60 hourMin h m = fromIntegral $ h * 3600 + m * 60
mkPaperBroker :: TickTableH -> BoundedChan Tick -> Price -> [T.Text] -> [CommissionConfig] -> IO BrokerInterface mkPaperBroker :: TickTableH -> BoundedChan Tick -> Price -> [T.Text] -> [CommissionConfig] -> LogAction IO Message -> IO BrokerBackend
mkPaperBroker tickTableH tickChan startCash accounts comms = do mkPaperBroker tickTableH tickChan startCash accounts comms l = do
state <- newIORef PaperBrokerState { state <- newIORef PaperBrokerState {
pbTid = Nothing, pbTid = Nothing,
tickTable = tickTableH, tickTable = tickTableH,
@ -68,18 +74,19 @@ mkPaperBroker tickTableH tickChan startCash accounts comms = do
postMarketStartTime = hourMin 15 40, postMarketStartTime = hourMin 15 40,
postMarketFixTime = hourMin 15 45, postMarketFixTime = hourMin 15 45,
postMarketCloseTime = hourMin 15 50, postMarketCloseTime = hourMin 15 50,
commissions = comms commissions = comms,
logger = l
} }
tid <- forkIO $ brokerThread tickChan state tid <- forkIO $ brokerThread tickChan state
atomicModifyIORef' state (\s -> (s { pbTid = Just tid }, ())) atomicModifyIORef' state (\s -> (s { pbTid = Just tid }, ()))
return BrokerInterface { return BrokerBackend {
accounts = accounts, accounts = accounts,
setNotificationCallback = pbSetNotificationCallback state, setNotificationCallback = pbSetNotificationCallback state,
submitOrder = pbSubmitOrder state, submitOrder = pbSubmitOrder state,
cancelOrder = pbCancelOrder state, cancelOrder = void . pbCancelOrder state,
stopBroker = pbDestroyBroker state } stop = pbDestroyBroker state }
brokerThread :: BoundedChan Tick -> IORef PaperBrokerState -> IO () brokerThread :: BoundedChan Tick -> IORef PaperBrokerState -> IO ()
@ -101,7 +108,7 @@ executePendingOrders tick state = do
then then
case orderPrice order of case orderPrice order of
Market -> do Market -> do
debugM "PaperBroker" "Executing: pending market order" log Debug "PaperBroker" "Executing: pending market order"
executeAtTick state order tick executeAtTick state order tick
return $ Just $ orderId order return $ Just $ orderId order
Limit price -> Limit price ->
@ -109,22 +116,27 @@ executePendingOrders tick state = do
_ -> return Nothing _ -> return Nothing
else return Nothing else return Nothing
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
executeLimitAt price order = case orderOperation order of executeLimitAt price order = case orderOperation order of
Buy -> if (datatype tick == LastTradePrice && price > value tick && value tick > 0) || (datatype tick == BestOffer && price > value tick && value tick > 0) Buy -> if (datatype tick == LastTradePrice && price > value tick && value tick > 0) ||
(datatype tick == BestOffer && price > value tick && value tick > 0)
then do then do
debugM "PaperBroker" $ "[1]Executing: pending limit order: " ++ show (security tick) ++ "/" ++ show (orderSecurity order) log Debug "PaperBroker" $ TL.toStrict $ [t|[1]Executing: pending limit order: %Q/%Q|] (security tick) (orderSecurity order)
executeAtTick state order $ tick { value = price } executeAtTick state order $ tick { value = price }
return $ Just $ orderId order return $ Just $ orderId order
else return Nothing else return Nothing
Sell -> if (datatype tick == LastTradePrice && price < value tick && value tick > 0) || (datatype tick == BestBid && price < value tick && value tick > 0) Sell -> if (datatype tick == LastTradePrice && price < value tick && value tick > 0) || (datatype tick == BestBid && price < value tick && value tick > 0)
then do then do
debugM "PaperBroker" $ "[2]Executing: pending limit order: " ++ show (security tick) ++ "/" ++ show (orderSecurity order) log Debug "PaperBroker" $ TL.toStrict $ [t|[2]Executing: pending limit order: %Q/%Q|] (security tick) (orderSecurity order)
executeAtTick state order $ tick { value = price } executeAtTick state order $ tick { value = price }
return $ Just $ orderId order return $ Just $ orderId order
else return Nothing else return Nothing
pbSetNotificationCallback :: IORef PaperBrokerState -> Maybe (Notification -> IO ()) -> IO() pbSetNotificationCallback :: IORef PaperBrokerState -> Maybe (BrokerBackendNotification -> IO ()) -> IO()
pbSetNotificationCallback state callback = atomicModifyIORef' state (\s -> (s { notificationCallback = callback }, ()) ) pbSetNotificationCallback state callback = atomicModifyIORef' state (\s -> (s { notificationCallback = callback }, ()) )
mkTrade :: TickerInfo -> Tick -> Order -> UTCTime -> Maybe CommissionConfig -> Trade mkTrade :: TickerInfo -> Tick -> Order -> UTCTime -> Maybe CommissionConfig -> Trade
@ -157,10 +169,10 @@ executeAtTick state order tick = do
comm <- L.find (\comdef -> comPrefix comdef `T.isPrefixOf` security tick) . commissions <$> readIORef state comm <- L.find (\comdef -> comPrefix comdef `T.isPrefixOf` security tick) . commissions <$> readIORef state
let tradeVolume = fromInteger (orderQuantity order) * value tick * fromInteger (tiLotSize tickerInfo) let tradeVolume = fromInteger (orderQuantity order) * value tick * fromInteger (tiLotSize tickerInfo)
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}, ()))
debugM "PaperBroker" $ "Executed: " ++ show newOrder ++ "; at tick: " ++ show tick log Debug "PaperBroker" $ TL.toStrict $ [t|Executed: %? at tick: %?|] newOrder tick
ts <- getCurrentTime ts <- getCurrentTime
maybeCall notificationCallback state $ TradeNotification $ mkTrade tickerInfo tick order ts comm maybeCall notificationCallback state $ BackendTradeNotification $ mkTrade tickerInfo tick order ts comm
maybeCall notificationCallback state $ OrderNotification (orderId order) Executed maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Executed
where where
obtainTickerInfo tickerId = do obtainTickerInfo tickerId = do
table <- tickTable <$> readIORef state table <- tickTable <$> readIORef state
@ -170,16 +182,20 @@ executeAtTick state order tick = do
_ -> return TickerInfo { tiTicker = tickerId, _ -> return TickerInfo { tiTicker = tickerId,
tiLotSize = 1, tiLotSize = 1,
tiTickSize = 1 } tiTickSize = 1 }
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
rejectOrder state order = do rejectOrder state order = do
let newOrder = order { orderState = Rejected } in let newOrder = order { orderState = Rejected } in
atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ())) atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ()))
maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Submitted
maybeCall notificationCallback state $ OrderNotification (orderId order) Rejected maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Rejected
pbSubmitOrder :: IORef PaperBrokerState -> Order -> IO () pbSubmitOrder :: IORef PaperBrokerState -> Order -> IO ()
pbSubmitOrder state order = do pbSubmitOrder state order = do
infoM "PaperBroker" $ "Submitted order: " ++ show order log Info "PaperBroker" $ "Submitted order: " <> (T.pack . show) order
case orderPrice order of case orderPrice order of
Market -> executeMarketOrder state order Market -> executeMarketOrder state order
Limit price -> submitLimitOrder price state order Limit price -> submitLimitOrder price state order
@ -187,6 +203,9 @@ pbSubmitOrder state order = do
StopMarket trigger -> submitStopMarketOrder state order StopMarket trigger -> submitStopMarketOrder state order
where where
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
executeMarketOrder state order = do executeMarketOrder state order = do
tm <- tickTable <$> readIORef state tm <- tickTable <$> readIORef state
tickMb <- getTick tm key tickMb <- getTick tm key
@ -200,25 +219,26 @@ pbSubmitOrder state order = do
else do else do
tm <- tickTable <$> readIORef state tm <- tickTable <$> readIORef state
tickMb <- getTick tm key tickMb <- getTick tm key
debugM "PaperBroker" $ "Limit order submitted, looking up: " ++ show key log Debug "PaperBroker" $ "Limit order submitted, looking up: " <> (T.pack . show) key
case tickMb of case tickMb of
Nothing -> do Nothing -> do
let newOrder = order { orderState = Submitted } let newOrder = order { orderState = Submitted }
atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ())) atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s }, ()))
maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Submitted
Just tick -> do Just tick -> do
marketOpenTime' <- marketOpenTime <$> readIORef state marketOpenTime' <- marketOpenTime <$> readIORef state
if (((orderOperation order == Buy) && (value tick < price)) || ((orderOperation order == Sell) && (value tick > price)) && (utctDayTime (timestamp tick) >= marketOpenTime')) if (((orderOperation order == Buy) && (value tick < price)) ||
((orderOperation order == Sell) && (value tick > price)) && (utctDayTime (timestamp tick) >= marketOpenTime'))
then do then do
maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Submitted
executeAtTick state order tick executeAtTick state order tick
else do else do
let newOrder = order { orderState = Submitted } let newOrder = order { orderState = Submitted }
atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , pendingOrders = newOrder : pendingOrders s}, ())) atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , pendingOrders = newOrder : pendingOrders s}, ()))
maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted maybeCall notificationCallback state $ BackendOrderNotification (orderId order) Submitted
submitStopOrder _ _ = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order submitStopOrder _ _ = log Warning "PaperBroker" $ "Not implemented: Submitted order: " <> (T.pack . show) order
submitStopMarketOrder _ _ = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order submitStopMarketOrder _ _ = log Warning "PaperBroker" $ "Not implemented: Submitted order: " <> (T.pack . show) order
orderDatatype = case orderOperation order of orderDatatype = case orderOperation order of
Buy -> BestOffer Buy -> BestOffer
@ -230,7 +250,7 @@ pbCancelOrder :: IORef PaperBrokerState -> OrderId -> IO Bool
pbCancelOrder state oid = do pbCancelOrder state oid = do
atomicModifyIORef' state (\s -> (s { pendingOrders = L.filter (\o -> orderId o /= oid) (pendingOrders s), atomicModifyIORef' state (\s -> (s { pendingOrders = L.filter (\o -> orderId o /= oid) (pendingOrders s),
orders = M.adjustWithKey (\_ v -> v { orderState = Cancelled }) oid (orders s) }, ())) orders = M.adjustWithKey (\_ v -> v { orderState = Cancelled }) oid (orders s) }, ()))
maybeCall notificationCallback state $ OrderNotification oid Cancelled maybeCall notificationCallback state $ BackendOrderNotification oid Cancelled
return True return True
pbDestroyBroker :: IORef PaperBrokerState -> IO () pbDestroyBroker :: IORef PaperBrokerState -> IO ()
@ -240,8 +260,3 @@ pbDestroyBroker state = do
Just tid -> killThread tid Just tid -> killThread tid
Nothing -> return () Nothing -> return ()
{-
pbGetOrder :: IORef PaperBrokerState -> OrderId -> IO (Maybe Order)
pbGetOrder state oid = M.lookup oid . orders <$> readIORef state
-}

150
src/Broker/QuikBroker.hs
Unescape View File

@ -1,49 +1,55 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE BangPatterns #-}
module Broker.QuikBroker ( module Broker.QuikBroker (
mkQuikBroker mkQuikBroker
) where ) where
import ATrade.Types import ATrade.Broker.Backend
import ATrade.Broker.Protocol import ATrade.Broker.Protocol
import ATrade.Broker.Server import ATrade.Broker.Server
import ATrade.Quotes.QTIS (TickerInfo(..)) import ATrade.Quotes.QTIS (TickerInfo (..))
import ATrade.Types
import Broker.QuikBroker.Trans2QuikApi hiding (tradeAccount) import Broker.QuikBroker.Trans2QuikApi hiding (logger, tradeAccount)
import Data.IORef import qualified Data.Bimap as BM
import Data.List.Split import Data.IORef
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Map as M import Data.List.Split
import qualified Data.Bimap as BM import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Text.Format
import Control.Monad import ATrade.Logging (Message, Severity (..),
import Control.Concurrent logWith)
import Control.Concurrent.BoundedChan import Colog (LogAction)
import Control.Monad.Trans.Except import Control.Concurrent
import Control.Monad.IO.Class import Control.Concurrent.BoundedChan
import System.Log.Logger import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Language.Haskell.Printf (t)
import Safe import Safe
import Commissions (CommissionConfig(..)) import Commissions (CommissionConfig (..))
import TickTable (TickTableH, getTick, getTickerInfo, TickKey(..)) import TickTable (TickKey (..), TickTableH,
getTick, getTickerInfo)
type QuikOrderId = Integer type QuikOrderId = Integer
data QuikBrokerState = QuikBrokerState { data QuikBrokerState = QuikBrokerState {
notificationCallback :: Maybe (Notification -> IO ()), notificationCallback :: Maybe (BrokerBackendNotification -> IO ()),
quik :: IORef Quik, quik :: IORef Quik,
orderMap :: M.Map OrderId Order, orderMap :: M.Map OrderId Order,
orderIdMap :: BM.Bimap QuikOrderId OrderId, orderIdMap :: BM.Bimap QuikOrderId OrderId,
trans2orderid :: M.Map Integer Order, trans2orderid :: M.Map Integer Order,
transIdCounter :: Integer, transIdCounter :: Integer,
tickTable :: TickTableH tickTable :: TickTableH,
logger :: LogAction IO Message
} }
nextTransId state = atomicModifyIORef' state (\s -> (s { transIdCounter = transIdCounter s + 1 }, transIdCounter s)) nextTransId state = atomicModifyIORef' state (\s -> (s { transIdCounter = transIdCounter s + 1 }, transIdCounter s))
@ -52,11 +58,11 @@ maybeCall proj state arg = do
cb <- proj <$> readIORef state cb <- proj <$> readIORef state
case cb of case cb of
Just callback -> callback arg Just callback -> callback arg
Nothing -> return () Nothing -> return ()
mkQuikBroker :: TickTableH -> FilePath -> FilePath -> [T.Text] -> [CommissionConfig] -> IO BrokerInterface mkQuikBroker :: TickTableH -> FilePath -> FilePath -> [T.Text] -> [CommissionConfig] -> LogAction IO Message -> IO BrokerBackend
mkQuikBroker tt dllPath quikPath accs comms = do mkQuikBroker tt dllPath quikPath accs comms l = do
q <- mkQuik dllPath quikPath q <- mkQuik dllPath quikPath l
msgChan <- newBoundedChan 100 msgChan <- newBoundedChan 100
@ -67,17 +73,18 @@ mkQuikBroker tt dllPath quikPath accs comms = do
orderIdMap = BM.empty, orderIdMap = BM.empty,
trans2orderid = M.empty, trans2orderid = M.empty,
transIdCounter = 1, transIdCounter = 1,
tickTable = tt tickTable = tt,
logger = l
} }
setCallbacks q (qbTransactionCallback state) (qbOrderCallback state) (qbTradeCallback state comms) setCallbacks q (qbTransactionCallback state) (qbOrderCallback state) (qbTradeCallback state comms)
return BrokerInterface { return BrokerBackend {
accounts = accs, accounts = accs,
setNotificationCallback = qbSetNotificationCallback state, setNotificationCallback = qbSetNotificationCallback state,
submitOrder = qbSubmitOrder state, submitOrder = qbSubmitOrder state,
cancelOrder = qbCancelOrder state, cancelOrder = void . qbCancelOrder state,
stopBroker = qbStopBroker state stop = qbStopBroker state
} }
qbSetNotificationCallback state maybecb = atomicModifyIORef' state (\s -> (s { qbSetNotificationCallback state maybecb = atomicModifyIORef' state (\s -> (s {
@ -88,24 +95,28 @@ qbSubmitOrder state order = do
transId <- nextTransId state transId <- nextTransId state
atomicModifyIORef' state (\s -> (s { atomicModifyIORef' state (\s -> (s {
trans2orderid = M.insert transId order (trans2orderid s) }, ())) trans2orderid = M.insert transId order (trans2orderid s) }, ()))
debugM "Quik" "Getting ticktable" log Debug "Quik" "Getting ticktable"
tt <- tickTable <$> readIORef state tt <- tickTable <$> readIORef state
debugM "Quik" "Getting tickerinfo from ticktable" log Debug "Quik" "Getting tickerinfo from ticktable"
tickerInfoMb <- getTickerInfo tt (orderSecurity order) tickerInfoMb <- getTickerInfo tt (orderSecurity order)
debugM "Quik" "Getting liquid ticks" log Debug "Quik" "Getting liquid ticks"
liquidTickMb <- getTick tt (TickKey (orderSecurity order) (if orderOperation order == Buy then BestOffer else BestBid)) liquidTickMb <- getTick tt (TickKey (orderSecurity order) (if orderOperation order == Buy then BestOffer else BestBid))
debugM "Quik" "Obtained" log Debug "Quik" "Obtained"
case (tickerInfoMb, liquidTickMb) of case (tickerInfoMb, liquidTickMb) of
(Just !tickerInfo, Just !liquidTick) -> (Just !tickerInfo, Just !liquidTick) ->
case makeTransactionString tickerInfo liquidTick transId order of case makeTransactionString tickerInfo liquidTick transId order of
Just transStr -> do Just transStr -> do
rc <- quikSendTransaction q transStr rc <- quikSendTransaction q transStr
debugM "Quik" $ "Sending transaction string: " ++ transStr log Debug "Quik" $ "Sending transaction string: " <> T.pack transStr
case rc of case rc of
Left errmsg -> warningM "Quik" $ "Unable to send transaction: " ++ T.unpack errmsg Left errmsg -> log Warning "Quik" $ "Unable to send transaction: " <> errmsg
Right _ -> debugM "Quik" $ "Order submitted: " ++ show order Right _ -> log Debug "Quik" $ "Order submitted: " <> (T.pack . show) order
Nothing -> warningM "Quik" $ "Unable to compose transaction string: " ++ show order Nothing -> log Warning "Quik" $ "Unable to compose transaction string: " <> (T.pack . show) order
_ -> warningM "Quik" $ "Unable to obtain data: " ++ show tickerInfoMb ++ "/" ++ show liquidTickMb _ -> log Warning "Quik" $ TL.toStrict $ [t|Unable to obtain data: %?/%?|] tickerInfoMb liquidTickMb
where
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
qbCancelOrder state orderid = do qbCancelOrder state orderid = do
@ -118,10 +129,14 @@ qbCancelOrder state orderid = do
Just transString -> do Just transString -> do
rc <- quikSendTransaction q transString rc <- quikSendTransaction q transString
case rc of case rc of
Left errmsg -> warningM "Quik" ("Unable to send transaction: " ++ T.unpack errmsg) >> return False Left errmsg -> log Warning "Quik" ("Unable to send transaction: " <> errmsg) >> return False
Right _ -> debugM "Quik" ("Order cancelled: " ++ show orderid) >> return True Right _ -> log Debug "Quik" ("Order cancelled: " <> (T.pack . show) orderid) >> return True
Nothing -> warningM "Quik" ("Unable to compose transaction string: " ++ show orderid) >> return False Nothing -> log Warning "Quik" ("Unable to compose transaction string: " <> (T.pack . show) orderid) >> return False
_ -> warningM "Quik" ("Got request to cancel unknown order: " ++ show orderid) >> return False _ -> log Warning "Quik" ("Got request to cancel unknown order: " <> (T.pack . show) orderid) >> return False
where
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
qbStopBroker state = return () qbStopBroker state = return ()
@ -139,11 +154,11 @@ makeTransactionString tickerInfo liquidTick transId order =
_ -> Nothing _ -> Nothing
where where
orderTypeCode = case orderPrice order of orderTypeCode = case orderPrice order of
Market -> "L" Market -> "L"
Limit _ -> "L" Limit _ -> "L"
_ -> "X" _ -> "X"
operationCode = case orderOperation order of operationCode = case orderOperation order of
Buy -> "B" Buy -> "B"
Sell -> "S" Sell -> "S"
classcode = headMay . splitOn "#" . T.unpack $ orderSecurity order classcode = headMay . splitOn "#" . T.unpack $ orderSecurity order
seccode = (`atMay` 1) . splitOn "#" . T.unpack $ orderSecurity order seccode = (`atMay` 1) . splitOn "#" . T.unpack $ orderSecurity order
@ -179,7 +194,7 @@ qbTransactionCallback state success transactionId orderNum = do
newOrder <- if success newOrder <- if success
then registerOrder orderNum $ order { orderState = Unsubmitted } then registerOrder orderNum $ order { orderState = Unsubmitted }
else registerOrder orderNum $ order { orderState = Rejected } else registerOrder orderNum $ order { orderState = Rejected }
maybeCall notificationCallback state (OrderNotification (orderId newOrder) (orderState newOrder)) maybeCall notificationCallback state (BackendOrderNotification (orderId newOrder) (orderState newOrder))
Nothing -> return () Nothing -> return ()
where where
@ -190,7 +205,7 @@ qbTransactionCallback state success transactionId orderNum = do
qbOrderCallback state quikorder = do qbOrderCallback state quikorder = do
orders <- orderMap <$> readIORef state orders <- orderMap <$> readIORef state
idMap <- orderIdMap <$> readIORef state idMap <- orderIdMap <$> readIORef state
debugM "Quik" $ "Order: " ++ show quikorder log Debug "Quik" $ "Order: " <> (T.pack . show) quikorder
case BM.lookup (qoOrderId quikorder) idMap >>= flip M.lookup orders of case BM.lookup (qoOrderId quikorder) idMap >>= flip M.lookup orders of
Just order -> do Just order -> do
updatedOrder <- if | qoStatus quikorder /= 1 && qoStatus quikorder /= 2 -> updatedOrder <- if | qoStatus quikorder /= 1 && qoStatus quikorder /= 2 ->
@ -201,8 +216,8 @@ qbOrderCallback state quikorder = do
submitted order submitted order
| qoStatus quikorder == 2 -> | qoStatus quikorder == 2 ->
cancelled order cancelled order
maybeCall notificationCallback state (OrderNotification (orderId updatedOrder) (orderState updatedOrder)) maybeCall notificationCallback state (BackendOrderNotification (orderId updatedOrder) (orderState updatedOrder))
Nothing -> warningM "Quik" $ "Unknown order: state callback called: " ++ show quikorder Nothing -> log Warning "Quik" $ "Unknown order: state callback called: " <> (T.pack . show) quikorder
where where
updateOrder :: Order -> IO Order updateOrder :: Order -> IO Order
@ -214,15 +229,19 @@ qbOrderCallback state quikorder = do
submitted order = updateOrder $ order { orderState = Submitted } submitted order = updateOrder $ order { orderState = Submitted }
cancelled order = updateOrder $ order { orderState = Cancelled } cancelled order = updateOrder $ order { orderState = Cancelled }
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
qbTradeCallback state comms quiktrade = do qbTradeCallback state comms quiktrade = do
orders <- orderMap <$> readIORef state orders <- orderMap <$> readIORef state
idMap <- orderIdMap <$> readIORef state idMap <- orderIdMap <$> readIORef state
debugM "Quik" $ "Trade: " ++ show quiktrade log Debug "Quik" $ "Trade: " <> (T.pack . show) quiktrade
case BM.lookup (qtOrderId quiktrade) idMap >>= flip M.lookup orders of case BM.lookup (qtOrderId quiktrade) idMap >>= flip M.lookup orders of
Just order -> do Just order -> do
debugM "Quik" $ "Found comm: " ++ show (L.find (\x -> comPrefix x `T.isPrefixOf` orderSecurity order) comms) log Debug "Quik" $ "Found comm: " <> (T.pack . show) (L.find (\x -> comPrefix x `T.isPrefixOf` orderSecurity order) comms)
maybeCall notificationCallback state (TradeNotification $ tradeFor order) maybeCall notificationCallback state (BackendTradeNotification $ tradeFor order)
Nothing -> warningM "Quik" $ "Incoming trade for unknown order: " ++ show quiktrade Nothing -> log Warning "Quik" $ "Incoming trade for unknown order: " <> (T.pack . show) quiktrade
where where
tradeFor order = Trade { tradeFor order = Trade {
tradeOrderId = orderId order, tradeOrderId = orderId order,
@ -241,3 +260,6 @@ qbTradeCallback state comms quiktrade = do
Just com -> vol * fromDouble (0.01 * comPercentage com) + fromDouble (comFixed com) * fromIntegral qty Just com -> vol * fromDouble (0.01 * comPercentage com) + fromDouble (comFixed com) * fromIntegral qty
Nothing -> 0 Nothing -> 0
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt

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

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Broker.QuikBroker.Trans2QuikApi ( module Broker.QuikBroker.Trans2QuikApi (
Trans2QuikApi(..), Trans2QuikApi(..),
@ -12,7 +13,9 @@ module Broker.QuikBroker.Trans2QuikApi (
quikSendTransaction quikSendTransaction
) where ) where
import ATrade.Logging (Message, Severity (..), logWith)
import Codec.Text.IConv import Codec.Text.IConv
import Colog (LogAction)
import Control.Concurrent import Control.Concurrent
import Control.Error.Util import Control.Error.Util
import Control.Exception.Safe import Control.Exception.Safe
@ -26,6 +29,7 @@ import Data.Ratio
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 Data.Text.Encoding import Data.Text.Encoding
import qualified Data.Text.Lazy as TL
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Clock import Data.Time.Clock
import Data.Typeable import Data.Typeable
@ -33,7 +37,8 @@ import Foreign
import Foreign.C.String import Foreign.C.String
import Foreign.C.Types import Foreign.C.Types
import Foreign.Marshal.Array import Foreign.Marshal.Array
import System.Log.Logger import Language.Haskell.Printf (t)
import Prelude hiding (log)
import System.Win32.DLL import System.Win32.DLL
import System.Win32.Types import System.Win32.Types
@ -393,7 +398,9 @@ data Quik = Quik {
watchdogTid :: ThreadId, watchdogTid :: ThreadId,
handledTrades :: S.Set CLLong, handledTrades :: S.Set CLLong,
handledOrders :: S.Set QuikOrder handledOrders :: S.Set QuikOrder,
logger :: LogAction IO Message
} }
quikSendTransaction :: IORef Quik -> String -> IO (Either T.Text ()) quikSendTransaction :: IORef Quik -> String -> IO (Either T.Text ())
@ -417,11 +424,12 @@ setCallbacks quik transCb orCb tradeCb = atomicModifyIORef' quik (\s ->
hlTradeCallback = Just tradeCb }, ())) hlTradeCallback = Just tradeCb }, ()))
mkQuik :: FilePath -> FilePath -> IO (IORef Quik) mkQuik :: FilePath -> FilePath -> LogAction IO Message -> IO (IORef Quik)
mkQuik dllpath quikpath = do mkQuik dllpath quikpath l = do
api <- loadQuikApi dllpath api <- loadQuikApi dllpath
debugM "Quik" "Dll loaded" let log = logWith l
log Debug "Quik" "Dll loaded"
myTid <- myThreadId myTid <- myThreadId
state <- newIORef Quik { quikApi = api, state <- newIORef Quik { quikApi = api,
@ -432,7 +440,8 @@ mkQuik dllpath quikpath = do
hlOrderCallback = Nothing, hlOrderCallback = Nothing,
hlTradeCallback = Nothing, hlTradeCallback = Nothing,
handledTrades = S.empty, handledTrades = S.empty,
handledOrders = S.empty } handledOrders = S.empty,
logger = l }
conncb' <- mkConnectionStatusCallback (defaultConnectionCb state) conncb' <- mkConnectionStatusCallback (defaultConnectionCb state)
transcb' <- mkTransactionsReplyCallback (defaultTransactionReplyCb state) transcb' <- mkTransactionsReplyCallback (defaultTransactionReplyCb state)
@ -446,25 +455,29 @@ mkQuik dllpath quikpath = do
tid <- forkIO $ watchdog quikpath state tid <- forkIO $ watchdog quikpath state
atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ())) atomicModifyIORef' state (\s -> (s { watchdogTid = tid }, ()))
debugM "Quik" "mkQuik done" log Debug "Quik" "mkQuik done"
return state return state
defaultConnectionCb :: IORef Quik -> LONG -> LONG -> LPSTR -> IO () defaultConnectionCb :: IORef Quik -> LONG -> LONG -> LPSTR -> IO ()
defaultConnectionCb state event errorCode infoMessage defaultConnectionCb state event errorCode infoMessage
| event == ecQuikConnected = infoM "Quik" "Quik connected" >> atomicModifyIORef' state (\s -> (s { connectedToServer = True }, ()) ) | event == ecQuikConnected = log Info "Quik" "Quik connected" >> atomicModifyIORef' state (\s -> (s { connectedToServer = True }, ()) )
| event == ecQuikDisconnected = infoM "Quik" "Quik disconnected" >> atomicModifyIORef' state (\s -> (s { connectedToServer = False }, ()) ) | event == ecQuikDisconnected = log Info "Quik" "Quik disconnected" >> atomicModifyIORef' state (\s -> (s { connectedToServer = False }, ()) )
| event == ecDllConnected = infoM "Quik" "DLL connected" >> atomicModifyIORef' state (\s -> (s { connectedToDll = True }, ()) ) | event == ecDllConnected = log Info "Quik" "DLL connected" >> atomicModifyIORef' state (\s -> (s { connectedToDll = True }, ()) )
| event == ecDllDisconnected = infoM "Quik" "DLL disconnected" >> atomicModifyIORef' state (\s -> (s { connectedToDll = True }, ()) ) | event == ecDllDisconnected = log Info "Quik" "DLL disconnected" >> atomicModifyIORef' state (\s -> (s { connectedToDll = True }, ()) )
| otherwise = debugM "Quik" $ "Connection event: " ++ show event | otherwise = log Debug "Quik" $ "Connection event: " <> (T.pack . show) event
where
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
defaultTransactionReplyCb :: IORef Quik -> LONG -> LONG -> LONG -> DWORD -> CLLong -> LPSTR -> CIntPtr -> IO () defaultTransactionReplyCb :: IORef Quik -> LONG -> LONG -> LONG -> DWORD -> CLLong -> LPSTR -> CIntPtr -> IO ()
defaultTransactionReplyCb state transactionResult errorCode replyCode transId orderNum replyMessage replyDesc = do defaultTransactionReplyCb state transactionResult errorCode replyCode transId orderNum replyMessage replyDesc = do
debugM "Quik" $ "Transaction cb:" ++ show transactionResult ++ "/" ++ show errorCode ++ "/" ++ show replyCode log Debug "Quik" $ TL.toStrict $ [t|Transaction cb: %d/%d/%d|] transactionResult errorCode replyCode
when (replyMessage /= nullPtr) $ do when (replyMessage /= nullPtr) $ do
s <- convert "CP1251" "UTF-8" . BL.fromStrict <$> BS.packCString replyMessage s <- convert "CP1251" "UTF-8" . BL.fromStrict <$> BS.packCString replyMessage
case decodeUtf8' (BL.toStrict s) of case decodeUtf8' (BL.toStrict s) of
Left _ -> warningM "Quik" "Unable to decode utf-8" Left _ -> log Warning "Quik" "Unable to decode utf-8"
Right msg -> debugM "Quik" $ "Transaction cb message:" ++ T.unpack msg Right msg -> log Debug "Quik" $ "Transaction cb message:" <> msg
maybecb <- hlTransactionCallback <$> readIORef state maybecb <- hlTransactionCallback <$> readIORef state
case maybecb of case maybecb of
@ -472,10 +485,13 @@ defaultTransactionReplyCb state transactionResult errorCode replyCode transId or
Nothing -> return () Nothing -> return ()
where where
rcInsufficientFunds = 4 rcInsufficientFunds = 4
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
defaultOrderCb :: IORef Quik -> LONG -> DWORD -> CLLong -> LPSTR -> LPSTR -> CDouble -> CLLong -> CDouble -> LONG -> LONG -> CIntPtr -> IO () 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 defaultOrderCb state mode transId dnumber classCode secCode price balance value sell status desc = do
debugM "Quik" $ "Trade cb: " ++ show mode ++ "/" ++ show dnumber ++ "/" ++ show transId log Debug "Quik" $ TL.toStrict $ [t|Trade cb: %d/%d/%d|] mode dnumber transId
orders <- handledOrders <$> readIORef state orders <- handledOrders <$> readIORef state
when (mode == 0) $ do when (mode == 0) $ do
maybecb <- hlOrderCallback <$> readIORef state maybecb <- hlOrderCallback <$> readIORef state
@ -487,21 +503,24 @@ defaultOrderCb state mode transId dnumber classCode secCode price balance value
case maybecb of case maybecb of
Just cb -> cb order Just cb -> cb order
Nothing -> return () Nothing -> return ()
where where
mkOrder :: String -> String -> QuikOrder mkOrder :: String -> String -> QuikOrder
mkOrder sclass ssec = QuikOrder { mkOrder sclass ssec = QuikOrder {
qoTransId = toInteger transId, qoTransId = toInteger transId,
qoOrderId = toInteger dnumber, qoOrderId = toInteger dnumber,
qoTicker = sclass ++ "#" ++ ssec, qoTicker = sclass ++ "#" ++ ssec,
qoPrice = toDouble price, qoPrice = toDouble price,
qoBalance = toInteger balance, qoBalance = toInteger balance,
qoSell = sell == 1, qoSell = sell == 1,
qoStatus = fromIntegral status qoStatus = fromIntegral status
} }
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
defaultTradeCb :: IORef Quik -> LONG -> CLLong -> CLLong -> LPSTR -> LPSTR -> CDouble -> CLLong -> CDouble -> LONG -> CIntPtr -> IO () 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 defaultTradeCb state mode dnumber orderNum classCode secCode price qty value sell desc = do
debugM "Quik" $ "Trade cb: " ++ show mode ++ "/" ++ show dnumber log Debug "Quik" $ TL.toStrict $ [t|Trade cb: %d/%d|] mode dnumber
trades <- handledTrades <$> readIORef state trades <- handledTrades <$> readIORef state
when (mode == 0 && dnumber `S.notMember` trades) $ do when (mode == 0 && dnumber `S.notMember` trades) $ do
atomicModifyIORef' state (\s -> (s { handledTrades = S.insert dnumber (handledTrades s) }, ())) atomicModifyIORef' state (\s -> (s { handledTrades = S.insert dnumber (handledTrades s) }, ()))
@ -517,8 +536,8 @@ defaultTradeCb state mode dnumber orderNum classCode secCode price qty value sel
currency <- tradeCurrency api desc >>= peekCString currency <- tradeCurrency api desc >>= peekCString
cb (trade ssec sclass ymd hms us currency) cb (trade ssec sclass ymd hms us currency)
Nothing -> return () Nothing -> return ()
where where
trade ssec sclass ymd hms us currency = QuikTrade { trade ssec sclass ymd hms us currency = QuikTrade {
qtOrderId = toInteger orderNum, qtOrderId = toInteger orderNum,
qtTicker = sclass ++ "#" ++ ssec, qtTicker = sclass ++ "#" ++ ssec,
qtPrice = toDouble price, qtPrice = toDouble price,
@ -528,8 +547,8 @@ defaultTradeCb state mode dnumber orderNum classCode secCode price qty value sel
qtVolumeCurrency = currency, qtVolumeCurrency = currency,
qtTimestamp = adjustTimestamp $ mkTimestamp ymd hms us qtTimestamp = adjustTimestamp $ mkTimestamp ymd hms us
} }
adjustTimestamp = addUTCTime (-3 * 3600) -- MSK -> UTC adjustTimestamp = addUTCTime (-3 * 3600) -- MSK -> UTC
mkTimestamp ymd hms us = UTCTime (fromGregorian y mon d) (fromInteger (h * 3600 + m * 60 + s) + fromRational (us % 1000000)) mkTimestamp ymd hms us = UTCTime (fromGregorian y mon d) (fromInteger (h * 3600 + m * 60 + s) + fromRational (us % 1000000))
where where
y = ymd `div` 10000 y = ymd `div` 10000
mon = fromEnum $ (ymd `mod` 10000) `div` 100 mon = fromEnum $ (ymd `mod` 10000) `div` 100
@ -537,6 +556,9 @@ defaultTradeCb state mode dnumber orderNum classCode secCode price qty value sel
h = hms `div` 10000 h = hms `div` 10000
m = (hms `mod` 10000) `div` 100 m = (hms `mod` 10000) `div` 100
s = hms `mod` 100 s = hms `mod` 100
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
watchdog :: FilePath -> IORef Quik -> IO () watchdog :: FilePath -> IORef Quik -> IO ()
@ -552,23 +574,27 @@ watchdog quikpath state = 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 log Warning "Quik.Watchdog" $ TL.toStrict $ [t|Error: %d|] err
else forever $ do else forever $ do
conn <- connectedToDll <$> readIORef state conn <- connectedToDll <$> readIORef state
handle handle
(\(QuikException errmsg rc) -> warningM "Quik.Watchdog" $ (T.unpack errmsg) ++ " (" ++ show rc ++ ")") $ (\(QuikException errmsg rc) -> log Warning "Quik.Watchdog" $ TL.toStrict $ [t|%Q (%d)|] errmsg 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 log Debug "Quik.Watchdog" $ "Unable to connect: " <> (T.pack . show) err
else withCString "" (\emptyStr -> do else withCString "" (\emptyStr -> do
throwIfErr "setTransactionsReplyCallback returned error" $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024 throwIfErr "setTransactionsReplyCallback returned error" $ setTransactionsReplyCallback api transcb errorCode errorMsg 1024
throwIfErr "subscribeOrders returned error" $ subscribeOrders api emptyStr emptyStr throwIfErr "subscribeOrders returned error" $ subscribeOrders api emptyStr emptyStr
startOrders api orcb startOrders api orcb
throwIfErr "subscribeTrades returned error" $ subscribeTrades api emptyStr emptyStr throwIfErr "subscribeTrades returned error" $ subscribeTrades api emptyStr emptyStr
startTrades api tradecb)) startTrades api tradecb))
threadDelay 10000000)) threadDelay 10000000))
where
log sev comp txt = do
l <- logger <$> readIORef state
logWith l sev comp txt
throwIfErr :: T.Text -> IO LONG -> IO () throwIfErr :: T.Text -> IO LONG -> IO ()
throwIfErr errmsg action = do throwIfErr errmsg action = do

22
src/QuoteSource/PipeReader.hs
Unescape View File

@ -6,8 +6,11 @@ module QuoteSource.PipeReader (
stopPipeReader stopPipeReader
) where ) where
import ATrade.Logging (Message, Severity (..),
logWith)
import ATrade.QuoteSource.Server import ATrade.QuoteSource.Server
import ATrade.Types import ATrade.Types
import Colog (LogAction)
import Control.Applicative import Control.Applicative
import Control.Concurrent hiding (readChan, writeChan, import Control.Concurrent hiding (readChan, writeChan,
writeList2Chan, yield) writeList2Chan, yield)
@ -35,7 +38,6 @@ import Data.Time.Clock
import Foreign.Marshal.Alloc import Foreign.Marshal.Alloc
import Safe import Safe
import System.IO import System.IO
import System.Log.Logger (debugM, warningM)
import System.ZMQ4 import System.ZMQ4
@ -46,10 +48,10 @@ data PipeReaderHandle =
} deriving (Eq) } deriving (Eq)
zmqSocketConduit :: (Subscriber a, Receiver a) => T.Text -> Socket a -> IORef Bool -> Source IO [B.ByteString] zmqSocketConduit :: (Subscriber a, Receiver a) => T.Text -> Socket a -> IORef Bool -> LogAction IO Message -> Source IO [B.ByteString]
zmqSocketConduit ep sock running' = do zmqSocketConduit ep sock running' logger = do
liftIO $ do liftIO $ do
debugM "PipeReader" $ "Connecting to: " ++ T.unpack ep logWith logger Info "PipeReader" $ "Connecting to: " <> ep
connect sock (T.unpack ep) connect sock (T.unpack ep)
subscribe sock B.empty subscribe sock B.empty
lastHeartbeat <- liftIO $ getCurrentTime >>= newIORef lastHeartbeat <- liftIO $ getCurrentTime >>= newIORef
@ -59,7 +61,7 @@ zmqSocketConduit ep sock running' = do
bs <- liftIO $ receiveMulti sock bs <- liftIO $ receiveMulti sock
when ((not . null $ bs) && (head bs == "SYSTEM#HEARTBEAT")) $ liftIO $ getCurrentTime >>= writeIORef lastHeartbeat when ((not . null $ bs) && (head bs == "SYSTEM#HEARTBEAT")) $ liftIO $ getCurrentTime >>= writeIORef lastHeartbeat
yield bs yield bs
zmqSocketConduit ep sock running' zmqSocketConduit ep sock running' logger
where where
notTimeout hb = do notTimeout hb = do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
@ -80,16 +82,16 @@ chanSink chan = awaitForever
(\t -> do (\t -> do
liftIO $ writeChan chan t) liftIO $ writeChan chan t)
startPipeReader :: Context -> T.Text -> BoundedChan QuoteSourceServerData -> IO PipeReaderHandle startPipeReader :: Context -> T.Text -> BoundedChan QuoteSourceServerData -> LogAction IO Message -> IO PipeReaderHandle
startPipeReader ctx pipeEndpoint tickChan = do startPipeReader ctx pipeEndpoint tickChan logger = do
debugM "PipeReader" $ "Trying to open pipe: " ++ T.unpack pipeEndpoint logWith logger Debug "PipeReader" $ "Trying to open pipe: " <> pipeEndpoint
s <- socket ctx Sub s <- socket ctx Sub
debugM "PipeReader" "Pipe opened" logWith logger Info "PipeReader" "Pipe opened"
running' <- newIORef True running' <- newIORef True
tid <- forkIO $ readerThread s running' tid <- forkIO $ readerThread s running'
return PipeReaderHandle { prThreadId = tid, running = running' } return PipeReaderHandle { prThreadId = tid, running = running' }
where where
readerThread s running' = runConduit $ (zmqSocketConduit pipeEndpoint s running') =$= parseBarConduit =$= qssdataConduit =$= chanSink tickChan readerThread s running' = runConduit $ (zmqSocketConduit pipeEndpoint s running' logger) =$= parseBarConduit =$= qssdataConduit =$= chanSink tickChan
stopPipeReader :: PipeReaderHandle -> IO () stopPipeReader :: PipeReaderHandle -> IO ()
stopPipeReader h = killThread (prThreadId h) >> writeIORef (running h) False stopPipeReader h = killThread (prThreadId h) >> writeIORef (running h) False

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

@ -40,7 +40,6 @@ 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 System.Log.Logger (debugM, warningM)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
@ -122,7 +121,6 @@ ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2
handleConnect state hsz1 hsz2 = do handleConnect state hsz1 hsz2 = do
myDdeState <- readIORef state myDdeState <- readIORef state
maybeAppName <- queryString myDdeState 256 hsz2 maybeAppName <- queryString myDdeState 256 hsz2
debugM "DDE" $ "Handle connect:" ++ show maybeAppName
case maybeAppName of case maybeAppName of
Just incomingAppName -> do Just incomingAppName -> do
if incomingAppName == appName myDdeState if incomingAppName == appName myDdeState
@ -140,7 +138,6 @@ ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2
Just topic -> withDdeData hData (\xlData -> do Just topic -> withDdeData hData (\xlData -> do
case runGetOrFail xlParser $ BL.fromStrict xlData of case runGetOrFail xlParser $ BL.fromStrict xlData of
Left (_, _, errmsg) -> do Left (_, _, errmsg) -> do
warningM "DDE" $ "Parsing error: " ++ show errmsg
return ddeResultFalse return ddeResultFalse
Right (_, _, table) -> do Right (_, _, table) -> do
rc <- (dataCallback myDdeState) topic table rc <- (dataCallback myDdeState) topic table

3
src/TickTable.hs
Unescape View File

@ -24,8 +24,6 @@ import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import System.Log.Logger (debugM)
import System.ZMQ4 (Context) import System.ZMQ4 (Context)
data TickKey = TickKey TickerId DataType data TickKey = TickKey TickerId DataType
@ -62,7 +60,6 @@ mkTickTable chan ctx qtisEndpoint = do
qtisThread r qtisChan ctx qtisEndpoint = forever $ do qtisThread r qtisChan ctx qtisEndpoint = forever $ do
threadDelay 1000000 threadDelay 1000000
requests <- readListFromChan qtisChan requests <- readListFromChan qtisChan
debugM "TickTable" $ "Requested info for tickers: " ++ show requests
ti <- qtisGetTickersInfo ctx qtisEndpoint (catMaybes $ fmap requestToTicker requests) ti <- qtisGetTickersInfo ctx qtisEndpoint (catMaybes $ fmap requestToTicker requests)
forM_ ti (\newInfo -> atomicModifyIORef' r (\s -> (s { tickerInfo = M.insert (tiTicker newInfo) newInfo $! tickerInfo s }, ()))) forM_ ti (\newInfo -> atomicModifyIORef' r (\s -> (s { tickerInfo = M.insert (tiTicker newInfo) newInfo $! tickerInfo s }, ())))

14
stack.yaml
Unescape View File

@ -15,7 +15,7 @@
# resolver: # resolver:
# name: custom-snapshot # name: custom-snapshot
# location: "./custom-snapshot.yaml" # location: "./custom-snapshot.yaml"
resolver: lts-17.14 resolver: lts-18.18
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@ -39,13 +39,19 @@ packages:
- '.' - '.'
- '../libatrade' - '../libatrade'
- '../zeromq4-haskell-zap' - '../zeromq4-haskell-zap'
- '../iconv' - '../iconv-0.4.1.3'
# Dependency packages to be pulled from upstream that are not in the resolver # Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3) # (e.g., acme-missiles-0.3)
extra-deps: [ "datetime-0.3.1", "cond-0.4.1.1", "gi-gtk-3.0.23", "gi-gdk-3.0.16", "gi-gdkpixbuf-2.0.16", "gi-gio-2.0.18", "gi-pango-1.0.16", "text-format-0.3.2", "th-printf-0.5.1"] extra-deps:
- datetime-0.3.1
- cond-0.4.1.1
- co-log-0.4.0.1@sha256:3d4c17f37693c80d1aa2c41669bc3438fac3e89dc5f479e57d79bc3ddc4dfcc5,5087
- ansi-terminal-0.10.3@sha256:e2fbcef5f980dc234c7ad8e2fa433b0e8109132c9e643bc40ea5608cd5697797,3226
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
flags: {} flags:
mintty:
Win32-2-13-1: false
# Extra package databases containing global packages # Extra package databases containing global packages
extra-package-dbs: [] extra-package-dbs: []

Write Preview
Loading…
Cancel
Save