Commissions support

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)

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

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"

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
+-}
 

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
+

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)

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 )
+

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

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"]