From 52a5fde6f4e8eeef434ba07433680c56bc9b5591 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 17 Dec 2017 12:19:05 +0700 Subject: [PATCH] Commissions support --- app/Config.hs | 8 +++- app/Main.hs | 4 +- quik-connector.cabal | 3 ++ src/Broker/PaperBroker.hs | 46 +++++++++++++-------- src/Broker/QuikBroker.hs | 19 ++++++--- src/Broker/QuikBroker/Trans2QuikApi.hs | 10 +++++ src/Commissions.hs | 21 ++++++++++ src/ReplayServer.hs | 56 ++++++++++++++++++++++++++ stack.yaml | 1 + 9 files changed, 143 insertions(+), 25 deletions(-) create mode 100644 src/Commissions.hs create mode 100644 src/ReplayServer.hs diff --git a/app/Config.hs b/app/Config.hs index 3936563..18d465b 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -7,6 +7,7 @@ module Config ( ) where +import Commissions (CommissionConfig) import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString.Lazy as BL @@ -36,7 +37,8 @@ data Config = Config { quikAccounts :: [T.Text], tradeSink :: T.Text, telegramToken :: T.Text, - telegramChatId :: T.Text + telegramChatId :: T.Text, + commissions :: [CommissionConfig] } deriving (Show) readConfig :: String -> IO Config @@ -65,6 +67,7 @@ parseConfig = withObject "object" $ \obj -> do trsink <- obj .: "trade-sink" tgToken <- obj .: "telegram-token" tgChatId <- obj .: "telegram-chatid" + commissionsConfig <- obj .: "commissions" accs <- V.toList <$> obj .: "accounts" return Config { quotesourceEndpoint = qse, qtisEndpoint = qtisEp, @@ -81,7 +84,8 @@ parseConfig = withObject "object" $ \obj -> do quikAccounts = fmap T.pack accs, tradeSink = trsink, telegramToken = tgToken, - telegramChatId = tgChatId } + telegramChatId = tgChatId, + commissions = commissionsConfig } where parseTables :: Value -> Parser [TableConfig] parseTables = withArray "array" $ \arr -> mapM parseTableConfig (V.toList arr) diff --git a/app/Main.hs b/app/Main.hs index 132c363..39f3843 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -72,9 +72,9 @@ main = do (forkId, c1, c2) <- forkBoundedChan 10000 chan - brokerQ <- mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config) + brokerQ <- mkQuikBroker (dllPath config) (quikPath config) (quikAccounts config) (commissions config) withContext (\ctx -> do - brokerP <- mkPaperBroker ctx (T.pack $ qtisEndpoint config) c1 1000000 ["demo"] + brokerP <- mkPaperBroker ctx (T.pack $ qtisEndpoint config) c1 1000000 ["demo"] (commissions config) withZapHandler ctx (\zap -> do zapSetWhitelist zap $ whitelist config zapSetBlacklist zap $ blacklist config diff --git a/quik-connector.cabal b/quik-connector.cabal index b25f817..8310d48 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -24,6 +24,7 @@ library , Broker.QuikBroker.Trans2QuikApi , Network.Telegram , ATrade.Quotes.QTIS + , Commissions ghc-options: -Wall -Wunsupported-calling-conventions build-depends: base >= 4.7 && < 5 , Win32 @@ -67,6 +68,7 @@ library , incremental-parser , attoparsec , safe-exceptions + , iconv default-language: Haskell2010 -- extra-libraries: "user32" other-modules: System.Win32.XlParser @@ -101,6 +103,7 @@ executable quik-connector-exe , directory , errors , safe-exceptions + , iconv default-language: Haskell2010 other-modules: Config -- extra-libraries: "user32" diff --git a/src/Broker/PaperBroker.hs b/src/Broker/PaperBroker.hs index 83b95e6..7ab3010 100644 --- a/src/Broker/PaperBroker.hs +++ b/src/Broker/PaperBroker.hs @@ -7,7 +7,6 @@ module Broker.PaperBroker ( mkPaperBroker ) where -import Control.DeepSeq import Data.Hashable import Data.Bits import ATrade.Types @@ -26,6 +25,8 @@ import System.Log.Logger import ATrade.Quotes.QTIS import System.ZMQ4 +import Commissions (CommissionConfig(..)) + data TickMapKey = TickMapKey !T.Text !DataType deriving (Show, Eq, Ord) @@ -52,14 +53,15 @@ data PaperBrokerState = PaperBrokerState { marketOpenTime :: DiffTime, postMarketStartTime :: DiffTime, postMarketFixTime :: DiffTime, - postMarketCloseTime :: DiffTime + postMarketCloseTime :: DiffTime, + commissions :: [CommissionConfig] } hourMin :: Integer -> Integer -> DiffTime hourMin h m = fromIntegral $ h * 3600 + m * 60 -mkPaperBroker :: Context -> T.Text -> BoundedChan Tick -> Price -> [T.Text] -> IO BrokerInterface -mkPaperBroker ctx qtisEp tickChan startCash accounts = do +mkPaperBroker :: Context -> T.Text -> BoundedChan Tick -> Price -> [T.Text] -> [CommissionConfig] -> IO BrokerInterface +mkPaperBroker ctx qtisEp tickChan startCash accounts comms = do state <- newIORef PaperBrokerState { pbTid = Nothing, qtisTid = Nothing, @@ -76,7 +78,8 @@ mkPaperBroker ctx qtisEp tickChan startCash accounts = do marketOpenTime = hourMin 7 0, postMarketStartTime = hourMin 15 40, postMarketFixTime = hourMin 15 45, - postMarketCloseTime = hourMin 15 50 + postMarketCloseTime = hourMin 15 50, + commissions = comms } qtisRequestChan <- newBoundedChan 10000 @@ -129,7 +132,9 @@ brokerThread qtisRequestChan chan state = forever $ do writeChan qtisRequestChan (security tick) atomicModifyIORef' state (\s -> (s { tickMap = M.insert (makeKey tick) tick $! tickMap s }, ())) - executePendingOrders tick state + marketOpenTime' <- marketOpenTime <$> readIORef state + when ((utctDayTime . timestamp) tick >= marketOpenTime') $ + executePendingOrders tick state where makeKey !tick = TickMapKey (security $! tick) (datatype tick) @@ -146,11 +151,12 @@ executePendingOrders tick state = do debugM "PaperBroker" "Executing: pending market order" executeAtTick state order tick return $ Just $ orderId order - Limit price -> do + Limit price -> executeLimitAt price order _ -> return Nothing else return Nothing + 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) then do @@ -168,18 +174,23 @@ executePendingOrders tick state = do pbSetNotificationCallback :: IORef PaperBrokerState -> Maybe (Notification -> IO ()) -> IO() pbSetNotificationCallback state callback = atomicModifyIORef' state (\s -> (s { notificationCallback = callback }, ()) ) -mkTrade :: TickerInfo -> Tick -> Order -> UTCTime -> Trade -mkTrade info tick order timestamp = Trade { +mkTrade :: TickerInfo -> Tick -> Order -> UTCTime -> Maybe CommissionConfig -> Trade +mkTrade info tick order timestamp comconf = Trade { tradeOrderId = orderId order, tradePrice = value tick, tradeQuantity = orderQuantity order, - tradeVolume = fromInteger (orderQuantity order) * value tick * fromInteger (tiLotSize info), + tradeVolume = thisTradeVolume, tradeVolumeCurrency = "TEST", tradeOperation = orderOperation order, tradeAccount = orderAccountId order, tradeSecurity = orderSecurity order, tradeTimestamp = timestamp, + tradeCommission = 0 `fromMaybe` (calcCommission thisTradeVolume <$> comconf), tradeSignalId = orderSignalId order } + where + -- Futures have incorrect lotsize + thisTradeVolume = fromInteger (orderQuantity order) * value tick * if "SPBFUT" `T.isPrefixOf` security tick then 1 else fromInteger (tiLotSize info) + calcCommission vol c = vol * 0.01 * fromDouble (comPercentage c) + fromDouble (comFixed c) * fromIntegral (orderQuantity order) maybeCall proj state arg = do cb <- proj <$> readIORef state @@ -190,11 +201,12 @@ maybeCall proj state arg = do executeAtTick state order tick = do let newOrder = order { orderState = Executed } tickerInfo <- obtainTickerInfo (security tick) + comm <- L.find (\comdef -> comPrefix comdef `T.isPrefixOf` security tick) . commissions <$> readIORef state 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}, ())) debugM "PaperBroker" $ "Executed: " ++ show newOrder ++ "; at tick: " ++ show tick ts <- getCurrentTime - maybeCall notificationCallback state $ TradeNotification $ mkTrade tickerInfo tick order ts + maybeCall notificationCallback state $ TradeNotification $ mkTrade tickerInfo tick order ts comm maybeCall notificationCallback state $ OrderNotification (orderId order) Executed where obtainTickerInfo tickerId = do @@ -248,19 +260,19 @@ pbSubmitOrder state order = do atomicModifyIORef' state (\s -> (s { orders = M.insert (orderId order) newOrder $ orders s , pendingOrders = newOrder : pendingOrders s}, ())) maybeCall notificationCallback state $ OrderNotification (orderId order) Submitted - submitStopOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order - submitStopMarketOrder state order = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order + submitStopOrder _ _ = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order + submitStopMarketOrder _ _ = warningM "PaperBroker" $ "Not implemented: Submitted order: " ++ show order - orderDatatype order = case orderOperation order of + orderDatatype = case orderOperation order of Buy -> BestOffer Sell -> BestBid - key = TickMapKey (orderSecurity order) (orderDatatype order) + key = TickMapKey (orderSecurity order) orderDatatype pbCancelOrder :: IORef PaperBrokerState -> OrderId -> IO Bool pbCancelOrder state oid = do atomicModifyIORef' state (\s -> (s { pendingOrders = L.filter (\o -> orderId o /= oid) (pendingOrders s), - orders = M.adjustWithKey (\k v -> v { orderState = Cancelled }) oid (orders s) }, ())) + orders = M.adjustWithKey (\_ v -> v { orderState = Cancelled }) oid (orders s) }, ())) maybeCall notificationCallback state $ OrderNotification oid Cancelled return True @@ -271,6 +283,8 @@ pbDestroyBroker state = do Just tid -> killThread tid Nothing -> return () +{- pbGetOrder :: IORef PaperBrokerState -> OrderId -> IO (Maybe Order) pbGetOrder state oid = M.lookup oid . orders <$> readIORef state +-} diff --git a/src/Broker/QuikBroker.hs b/src/Broker/QuikBroker.hs index d893a70..56924ee 100644 --- a/src/Broker/QuikBroker.hs +++ b/src/Broker/QuikBroker.hs @@ -29,6 +29,8 @@ import System.Log.Logger import Safe +import Commissions (CommissionConfig(..)) + type QuikOrderId = Integer data QuikBrokerState = QuikBrokerState { @@ -48,8 +50,8 @@ maybeCall proj state arg = do Just callback -> callback arg Nothing -> return () -mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> IO BrokerInterface -mkQuikBroker dllPath quikPath accs = do +mkQuikBroker :: FilePath -> FilePath -> [T.Text] -> [CommissionConfig] -> IO BrokerInterface +mkQuikBroker dllPath quikPath accs comms = do q <- mkQuik dllPath quikPath msgChan <- newBoundedChan 100 @@ -63,7 +65,7 @@ mkQuikBroker dllPath quikPath accs = do transIdCounter = 1 } - setCallbacks q (qbTransactionCallback state) (qbOrderCallback state) (qbTradeCallback state) + setCallbacks q (qbTransactionCallback state) (qbOrderCallback state) (qbTradeCallback state comms) return BrokerInterface { accounts = accs, @@ -195,12 +197,14 @@ qbOrderCallback state quikorder = do submitted order = updateOrder $ order { orderState = Submitted } cancelled order = updateOrder $ order { orderState = Cancelled } -qbTradeCallback state quiktrade = do +qbTradeCallback state comms 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) + Just order -> do + debugM "Quik" $ "Found comm: " ++ show (L.find (\x -> comPrefix x `T.isPrefixOf` orderSecurity order) comms) + maybeCall notificationCallback state (TradeNotification $ tradeFor order) Nothing -> warningM "Quik" $ "Incoming trade for unknown order: " ++ show quiktrade where tradeFor order = Trade { @@ -213,5 +217,10 @@ qbTradeCallback state quiktrade = do tradeAccount = orderAccountId order, tradeSecurity = orderSecurity order, tradeTimestamp = qtTimestamp quiktrade, + tradeCommission = calculateCommission (orderSecurity order) (fromDouble $ qtVolume quiktrade) (qtQuantity quiktrade), tradeSignalId = orderSignalId order } + calculateCommission sec vol qty = case L.find (\x -> comPrefix x `T.isPrefixOf` sec) comms of + Just com -> vol * fromDouble (0.01 * comPercentage com) + fromDouble (comFixed com) * fromIntegral qty + Nothing -> 0 + diff --git a/src/Broker/QuikBroker/Trans2QuikApi.hs b/src/Broker/QuikBroker/Trans2QuikApi.hs index 92fed6a..ae09053 100644 --- a/src/Broker/QuikBroker/Trans2QuikApi.hs +++ b/src/Broker/QuikBroker/Trans2QuikApi.hs @@ -29,9 +29,13 @@ import Data.Time.Clock import Data.Time.Calendar import Data.Ratio import Data.Typeable +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL import qualified Data.Set as S import qualified Data.Text as T +import Data.Text.Encoding import System.Log.Logger +import Codec.Text.IConv type QuikErrorCode = LONG @@ -456,6 +460,12 @@ defaultConnectionCb state event errorCode infoMessage defaultTransactionReplyCb :: IORef Quik -> LONG -> LONG -> LONG -> DWORD -> CLLong -> LPSTR -> CIntPtr -> IO () defaultTransactionReplyCb state transactionResult errorCode replyCode transId orderNum replyMessage replyDesc = do debugM "Quik" $ "Transaction cb:" ++ show transactionResult ++ "/" ++ show errorCode ++ "/" ++ show replyCode + when (replyMessage /= nullPtr) $ do + s <- convert "CP1251" "UTF-8" . BL.fromStrict <$> BS.packCString replyMessage + case decodeUtf8' (BL.toStrict s) of + Left _ -> warningM "Quik" "Unable to decode utf-8" + Right msg -> debugM "Quik" $ "Transaction cb message:" ++ T.unpack msg + maybecb <- hlTransactionCallback <$> readIORef state case maybecb of Just cb -> cb (transactionResult == ecSuccess) (toInteger transId) (toInteger orderNum) diff --git a/src/Commissions.hs b/src/Commissions.hs new file mode 100644 index 0000000..7fee7b1 --- /dev/null +++ b/src/Commissions.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Commissions ( + CommissionConfig(..) +) where + +import Data.Aeson +import qualified Data.Text as T + +data CommissionConfig = CommissionConfig { + comPrefix :: T.Text, + comPercentage :: Double, + comFixed :: Double +} deriving (Show) + +instance FromJSON CommissionConfig where + parseJSON = withObject "object" (\obj -> CommissionConfig <$> + obj .: "prefix" <*> + obj .:? "percentage" .!= 0 <*> + obj .:? "fixed" .!= 0 ) + diff --git a/src/ReplayServer.hs b/src/ReplayServer.hs new file mode 100644 index 0000000..0799168 --- /dev/null +++ b/src/ReplayServer.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE MultiWayIf, OverloadedStrings #-} + +module ReplayServer ( +) where + +import Data.Aeson +import Data.Aeson.Types +import Data.Maybe +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T + +import Control.Monad +import Control.Concurrent +import Control.Concurrent.MVar + +import Safe + +import System.ZMQ4 +import System.Log.Logger + +type ShutdownMVar = MVar () + +data Request = StartRecording FilePath | StopRecording | StartReplay FilePath | StopReplay +data Response = ResponseOk | ResponseError T.Text + +instance FromJSON Request where + parseJSON (Object v) = do + rq <- v .: "request" + if + | rq == ("start-recording" :: T.Text) -> StartRecording <$> v.: "filename" + | otherwise -> fail "Unknown request" + parseJSON invalid = typeMismatch "Request" invalid + +instance ToJSON Response where + toJSON ResponseOk = object ["response" .= ("ok" :: T.Text)] + toJSON (ResponseError errmsg) = object ["response" .= ("error" :: T.Text), "message" .= errmsg] + +startReplayServer :: Context -> T.Text -> IO ShutdownMVar +startReplayServer ctx ep = do + shutdownMVar <- newEmptyMVar + _ <- forkIO $ replayServerEventLoop shutdownMVar ctx ep + return shutdownMVar + +stopReplayServer :: ShutdownMVar -> IO () +stopReplayServer mv = void $ tryPutMVar mv () + +replayServerEventLoop shutdownMVar ctx ep = withSocket ctx Rep (\sock -> do + events <- poll 1000 [Sock sock [In] Nothing] + when (isJust $ headMay events >>= headMay) $ do + rawMsg <- receive sock + case eitherDecode (BL.fromStrict rawMsg) of + Right msg -> handle msg >>= send sock [] . BL.toStrict . encode + Left errmsg -> debugM "ReplayServer" $ "Got invalid command: " ++ errmsg) + where + handle :: Request -> IO Response + handle = undefined diff --git a/stack.yaml b/stack.yaml index 4811efe..f77f424 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,6 +39,7 @@ packages: - '.' - '../libatrade' - '../zeromq4-haskell-zap' +- '../iconv' # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) extra-deps: [ "datetime-0.3.1", "cond-0.4.1.1"]