From f9afe70c9e7a4eb67d97c83a284c1c62c12636b5 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 5 Jun 2021 12:19:51 +0700 Subject: [PATCH 1/4] Bump to lts-17.14 --- stack.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index fa86d9b..30bb862 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-12.9 +resolver: lts-17.14 # User packages to be built. # Various formats can be used as shown in the example below. @@ -40,7 +40,7 @@ packages: - '../zeromq4-haskell-zap' # 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", "hexdump-0.1", "text-format-0.3.2"] +extra-deps: [ "datetime-0.3.1", "hexdump-0.1"] # Override default flag values for local packages and extra-deps flags: {} From 002d00ea44ffe036e0a8060434d9a38f0243442c Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Fri, 9 Jul 2021 10:48:45 +0700 Subject: [PATCH 2/4] bugfix(build): use error instead of fail in Arbitrary OrderPrice instance fail is now a part of MonadFail class, and Arbitrary is not MonadFail, so I have to use `error` here. --- test/ArbitraryInstances.hs | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/test/ArbitraryInstances.hs b/test/ArbitraryInstances.hs index 932230b..5a4fc6a 100644 --- a/test/ArbitraryInstances.hs +++ b/test/ArbitraryInstances.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} module ArbitraryInstances ( ) where -import Test.Tasty.QuickCheck as QC -import Test.QuickCheck.Instances () +import Test.QuickCheck.Instances () +import Test.Tasty.QuickCheck as QC -import ATrade.Types -import ATrade.Price as P -import qualified Data.Text as T -import ATrade.Broker.Protocol +import ATrade.Broker.Protocol +import ATrade.Price as P +import ATrade.Types +import qualified Data.Text as T -import Data.Time.Clock -import Data.Time.Calendar +import Data.Time.Calendar +import Data.Time.Clock notTooBig :: (Num a, Ord a) => a -> Bool notTooBig x = abs x < 100000000 @@ -51,7 +53,7 @@ instance Arbitrary OrderPrice where | v == 2 -> Limit <$> arbitrary `suchThat` notTooBig | v == 3 -> Stop <$> arbitrary `suchThat` notTooBig <*> arbitrary `suchThat` notTooBig | v == 4 -> StopMarket <$> arbitrary `suchThat` notTooBig - | otherwise -> fail "Invalid case" + | otherwise -> error "Invalid case" instance Arbitrary Operation where arbitrary = elements [Buy, Sell] @@ -132,4 +134,4 @@ instance Arbitrary Bar where instance Arbitrary BarTimeframe where arbitrary = BarTimeframe <$> (arbitrary `suchThat` (\p -> p > 0 && p < 86400 * 365)) - + From e6708ce928f0a053533061a790a89251b1285788 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Fri, 9 Jul 2021 13:36:18 +0700 Subject: [PATCH 3/4] Separated orderId spaces for backends and BrokerServer --- libatrade.cabal | 38 ++--- src/ATrade/Broker/Backend.hs | 28 ++++ src/ATrade/Broker/Protocol.hs | 55 +++---- src/ATrade/Broker/Server.hs | 123 ++++++++-------- .../Broker/TradeSinks/TelegramTradeSink.hs | 63 ++++---- test/MockBroker.hs | 31 ++-- test/TestBrokerServer.hs | 134 +++++++++--------- 7 files changed, 254 insertions(+), 218 deletions(-) create mode 100644 src/ATrade/Broker/Backend.hs diff --git a/libatrade.cabal b/libatrade.cabal index 3c49f52..903a8a2 100644 --- a/libatrade.cabal +++ b/libatrade.cabal @@ -20,6 +20,7 @@ library , ATrade.Price , ATrade.QuoteSource.Client , ATrade.QuoteSource.Server + , ATrade.Broker.Backend , ATrade.Broker.Client , ATrade.Broker.Protocol , ATrade.Broker.Server @@ -29,32 +30,33 @@ library , ATrade other-modules: Paths_libatrade build-depends: base >= 4.7 && < 5 - , time - , datetime - , bytestring - , text - , binary - , aeson , BoundedChan - , hslogger - , zeromq4-haskell - , zeromq4-haskell-zap - , unordered-containers + , aeson + , bimap + , binary + , bytestring + , connection , containers - , monad-loops - , safe - , stm + , datetime , deepseq , errors - , text-format - , parsec , extra - , connection + , gitrev + , hslogger , http-client , http-client-tls - , utf8-string + , monad-loops + , parsec + , safe , scientific - , gitrev + , stm + , text + , th-printf + , time + , unordered-containers + , utf8-string + , zeromq4-haskell + , zeromq4-haskell-zap default-language: Haskell2010 diff --git a/src/ATrade/Broker/Backend.hs b/src/ATrade/Broker/Backend.hs new file mode 100644 index 0000000..98bf7e6 --- /dev/null +++ b/src/ATrade/Broker/Backend.hs @@ -0,0 +1,28 @@ + +module ATrade.Broker.Backend +( + BrokerBackend(..), + BrokerBackendNotification(..), + backendNotificationOrderId +) where + +import ATrade.Types +import qualified Data.Text as T + +data BrokerBackendNotification = + BackendTradeNotification Trade | + BackendOrderNotification OrderId OrderState + deriving (Show, Eq) + +backendNotificationOrderId :: BrokerBackendNotification -> OrderId +backendNotificationOrderId (BackendOrderNotification oid _) = oid +backendNotificationOrderId (BackendTradeNotification trade) = tradeOrderId trade + +data BrokerBackend = BrokerBackend + { + accounts :: [T.Text], + setNotificationCallback :: (Maybe (BrokerBackendNotification -> IO ())) -> IO (), + submitOrder :: Order -> IO (), + cancelOrder :: OrderId -> IO (), + stop :: IO () + } diff --git a/src/ATrade/Broker/Protocol.hs b/src/ATrade/Broker/Protocol.hs index ebc4c55..30ffeca 100644 --- a/src/ATrade/Broker/Protocol.hs +++ b/src/ATrade/Broker/Protocol.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE OverloadedStrings, MultiWayIf, RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} module ATrade.Broker.Protocol ( BrokerServerRequest(..), @@ -12,18 +15,18 @@ module ATrade.Broker.Protocol ( ClientIdentity(..) ) where -import Control.Error.Util -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import Data.Text.Format -import Data.Text.Encoding -import Data.Aeson -import Data.Aeson.Types hiding (parse) -import Data.Int -import Data.Time.Clock -import Data.Time.Calendar -import ATrade.Types -import Text.Parsec +import ATrade.Types +import Control.Error.Util +import Data.Aeson +import Data.Aeson.Types hiding (parse) +import qualified Data.HashMap.Strict as HM +import Data.Int +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Time.Calendar +import Data.Time.Clock +import Language.Haskell.Printf +import Text.Parsec type ClientIdentity = T.Text type RequestSqnum = Int64 @@ -103,7 +106,7 @@ notificationOrderId (TradeNotification trade) = tradeOrderId trade instance FromJSON Notification where parseJSON n = withObject "notification" (\obj -> case HM.lookup "trade" obj of - Just v -> parseTrade v + Just v -> parseTrade v Nothing -> parseOrder n) n where parseTrade v = TradeNotification <$> parseJSON v @@ -120,16 +123,16 @@ instance ToJSON Notification where toJSON (TradeNotification trade) = object ["trade" .= toJSON trade] data TradeSinkMessage = TradeSinkHeartBeat | TradeSinkTrade { - tsAccountId :: T.Text, - tsSecurity :: T.Text, - tsPrice :: Double, - tsQuantity :: Int, - tsVolume :: Double, - tsCurrency :: T.Text, - tsOperation :: Operation, + tsAccountId :: T.Text, + tsSecurity :: T.Text, + tsPrice :: Double, + tsQuantity :: Int, + tsVolume :: Double, + tsCurrency :: T.Text, + tsOperation :: Operation, tsExecutionTime :: UTCTime, - tsCommission :: Double, - tsSignalId :: SignalId + tsCommission :: Double, + tsSignalId :: SignalId } deriving (Show, Eq) mkTradeMessage trade = TradeSinkTrade { @@ -153,10 +156,10 @@ getHMS (UTCTime _ diff) = (intsec `div` 3600, (intsec `mod` 3600) `div` 60, ints intsec = floor diff msec = floor $ (diff - fromIntegral intsec) * 1000 -formatTimestamp dt = format "{}-{}-{} {}:{}:{}.{}" (left 4 '0' y, left 2 '0' m, left 2 '0' d, left 2 '0' hour, left 2 '0' min, left 2 '0' sec, left 3 '0' msec) +formatTimestamp dt = [t|%04d-%02d-%02d %02d:%02d:%02d.%03d|] y m d hour min sec msec where (y, m, d) = toGregorian $ utctDay dt - (hour, min, sec, msec) = getHMS dt + (hour, min, sec, msec) = getHMS dt parseTimestamp (String t) = case hush $ parse p "" t of Just ts -> return ts @@ -199,7 +202,7 @@ instance ToJSON TradeSinkMessage where instance FromJSON TradeSinkMessage where parseJSON = withObject "object" (\obj -> case HM.lookup "command" obj of - Nothing -> parseTrade obj + Nothing -> parseTrade obj Just cmd -> return TradeSinkHeartBeat) where parseTrade obj = case HM.lookup "trade" obj of diff --git a/src/ATrade/Broker/Server.hs b/src/ATrade/Broker/Server.hs index 995bf75..1bcdd52 100644 --- a/src/ATrade/Broker/Server.hs +++ b/src/ATrade/Broker/Server.hs @@ -3,69 +3,66 @@ module ATrade.Broker.Server ( startBrokerServer, stopBrokerServer, - BrokerInterface(..), + BrokerBackend(..), TradeSink ) where -import ATrade.Types -import ATrade.Broker.Protocol -import System.ZMQ4 -import System.ZMQ4.ZAP -import Data.List.NonEmpty -import qualified Data.Map as M -import qualified Data.ByteString as B hiding (putStrLn) -import qualified Data.ByteString.Lazy as BL hiding (putStrLn) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import qualified Data.List as L -import Data.Aeson -import Data.Maybe -import Data.Time.Clock -import Data.IORef -import Control.Concurrent hiding (readChan, writeChan) -import Control.Concurrent.BoundedChan -import Control.Exception -import Control.Monad -import Control.Monad.Loops -import System.Log.Logger -import System.Timeout -import ATrade.Util +import ATrade.Broker.Backend +import ATrade.Broker.Protocol +import ATrade.Types +import ATrade.Util +import Control.Concurrent hiding (readChan, writeChan) +import Control.Concurrent.BoundedChan +import Control.Exception +import Control.Monad +import Control.Monad.Loops +import Data.Aeson +import qualified Data.Bimap as BM +import qualified Data.ByteString as B hiding (putStrLn) +import qualified Data.ByteString.Lazy as BL hiding (putStrLn) +import Data.IORef +import qualified Data.List as L +import Data.List.NonEmpty +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Time.Clock +import System.Log.Logger +import System.Timeout +import System.ZMQ4 +import System.ZMQ4.ZAP newtype OrderIdGenerator = IO OrderId type PeerId = B.ByteString -data BrokerInterface = BrokerInterface { - accounts :: [T.Text], - setNotificationCallback :: Maybe (Notification -> IO()) -> IO (), - submitOrder :: Order -> IO (), - cancelOrder :: OrderId -> IO Bool, - stopBroker :: IO () -} +data FullOrderId = FullOrderId ClientIdentity OrderId + deriving (Show, Eq, Ord) data BrokerServerState = BrokerServerState { - bsSocket :: Socket Router, - orderToBroker :: M.Map OrderId BrokerInterface, - orderMap :: M.Map OrderId ClientIdentity, -- Matches 0mq client identities with corresponding orders - lastPacket :: M.Map PeerId (RequestSqnum, BrokerServerResponse), + bsSocket :: Socket Router, + orderToBroker :: M.Map FullOrderId BrokerBackend, + orderMap :: BM.Bimap FullOrderId OrderId, + lastPacket :: M.Map PeerId (RequestSqnum, BrokerServerResponse), pendingNotifications :: M.Map ClientIdentity [Notification], - brokers :: [BrokerInterface], - completionMvar :: MVar (), - killMvar :: MVar (), - orderIdCounter :: OrderId, - tradeSink :: BoundedChan Trade + brokers :: [BrokerBackend], + completionMvar :: MVar (), + killMvar :: MVar (), + orderIdCounter :: OrderId, + tradeSink :: BoundedChan Trade } data BrokerServerHandle = BrokerServerHandle ThreadId ThreadId (MVar ()) (MVar ()) type TradeSink = Trade -> IO () -startBrokerServer :: [BrokerInterface] -> Context -> T.Text -> [TradeSink] -> ServerSecurityParams -> IO BrokerServerHandle +startBrokerServer :: [BrokerBackend] -> Context -> T.Text -> [TradeSink] -> ServerSecurityParams -> IO BrokerServerHandle startBrokerServer brokers c ep tradeSinks params = do sock <- socket c Router setLinger (restrict 0) sock case sspDomain params of Just domain -> setZapDomain (restrict $ E.encodeUtf8 domain) sock - Nothing -> return () + Nothing -> return () case sspCertificate params of Just cert -> do setCurveServer True sock @@ -78,7 +75,7 @@ startBrokerServer brokers c ep tradeSinks params = do tsChan <- newBoundedChan 100 state <- newIORef BrokerServerState { bsSocket = sock, - orderMap = M.empty, + orderMap = BM.empty, orderToBroker = M.empty, lastPacket = M.empty, pendingNotifications = M.empty, @@ -93,16 +90,19 @@ startBrokerServer brokers c ep tradeSinks params = do debugM "Broker.Server" "Forking broker server thread" BrokerServerHandle <$> forkIO (brokerServerThread state) <*> forkIO (tradeSinkHandler c state tradeSinks) <*> pure compMv <*> pure killMv -notificationCallback :: IORef BrokerServerState -> Notification -> IO () +notificationCallback :: IORef BrokerServerState -> BrokerBackendNotification -> IO () notificationCallback state n = do debugM "Broker.Server" $ "Notification: " ++ show n chan <- tradeSink <$> readIORef state case n of - TradeNotification trade -> tryWriteChan chan trade - _ -> return False + BackendTradeNotification trade -> tryWriteChan chan trade + _ -> return False orders <- orderMap <$> readIORef state - case M.lookup (notificationOrderId n) orders of - Just clientIdentity -> addNotification clientIdentity n + case BM.lookupR (backendNotificationOrderId n) orders of + Just (FullOrderId clientIdentity localOrderId) -> + case n of + BackendTradeNotification trade -> addNotification clientIdentity (TradeNotification trade { tradeOrderId = localOrderId }) + BackendOrderNotification globalOrderId newstate -> addNotification clientIdentity (OrderNotification localOrderId newstate) Nothing -> warningM "Broker.Server" "Notification: unknown order" where @@ -118,7 +118,7 @@ tradeSinkHandler c state tradeSinks = unless (null tradeSinks) $ maybeTrade <- tryReadChan chan case maybeTrade of Just trade -> mapM_ (\x -> x trade) tradeSinks - Nothing -> threadDelay 100000 + Nothing -> threadDelay 100000 where wasKilled = isJust <$> (killMvar <$> readIORef state >>= tryReadMVar) @@ -178,23 +178,26 @@ brokerServerThread state = finally brokerServerThread' cleanup debugM "Broker.Server" $ "Request: submit order:" ++ show request case findBrokerForAccount (orderAccountId order) bros of Just bro -> do - oid <- nextOrderId + globalOrderId <- nextOrderId + let fullOrderId = (FullOrderId clientIdentity (orderId order)) atomicMapIORef state (\s -> s { - orderToBroker = M.insert oid bro (orderToBroker s), - orderMap = M.insert oid clientIdentity (orderMap s) }) - submitOrder bro order { orderId = oid } - return $ ResponseOrderSubmitted oid + orderToBroker = M.insert fullOrderId bro (orderToBroker s), + orderMap = BM.insert fullOrderId globalOrderId (orderMap s) }) + submitOrder bro order { orderId = globalOrderId } + return $ ResponseOrderSubmitted (orderId order) Nothing -> do debugM "Broker.Server" $ "Unknown account: " ++ T.unpack (orderAccountId order) return $ ResponseError "Unknown account" - RequestCancelOrder sqnum clientIdentity oid -> do + RequestCancelOrder sqnum clientIdentity localOrderId -> do m <- orderToBroker <$> readIORef state - case M.lookup oid m of - Just bro -> do - cancelOrder bro oid - return $ ResponseOrderCancelled oid - Nothing -> return $ ResponseError "Unknown order" + bm <- orderMap <$> readIORef state + let fullOrderId = FullOrderId clientIdentity localOrderId + case (M.lookup fullOrderId m, BM.lookup fullOrderId bm) of + (Just bro, Just globalOrderId) -> do + cancelOrder bro globalOrderId + return $ ResponseOrderCancelled localOrderId + _ -> return $ ResponseError "Unknown order" RequestNotifications sqnum clientIdentity -> do maybeNs <- M.lookup clientIdentity . pendingNotifications <$> readIORef state case maybeNs of diff --git a/src/ATrade/Broker/TradeSinks/TelegramTradeSink.hs b/src/ATrade/Broker/TradeSinks/TelegramTradeSink.hs index 13e8029..22d21ef 100644 --- a/src/ATrade/Broker/TradeSinks/TelegramTradeSink.hs +++ b/src/ATrade/Broker/TradeSinks/TelegramTradeSink.hs @@ -1,34 +1,35 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module ATrade.Broker.TradeSinks.TelegramTradeSink ( withTelegramTradeSink ) where -import Control.Exception -import Control.Concurrent +import Control.Concurrent import qualified Control.Concurrent.BoundedChan as BC -import Data.Aeson -import Data.Aeson.Types -import Data.IORef -import Data.Maybe -import Data.List.NonEmpty -import qualified Data.List as L -import qualified Data.ByteString as B hiding (putStrLn) -import qualified Data.ByteString.Lazy as BL hiding (putStrLn) -import System.Log.Logger -import Control.Monad.Loops -import Control.Monad.Extra +import Control.Exception +import Control.Monad.Extra +import Control.Monad.Loops +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString as B hiding (putStrLn) +import qualified Data.ByteString.Lazy as BL hiding (putStrLn) +import Data.IORef +import qualified Data.List as L +import Data.List.NonEmpty +import Data.Maybe +import System.Log.Logger -import ATrade.Types -import ATrade.Broker.Protocol -import Network.Connection -import Network.HTTP.Client -import Network.HTTP.Client.TLS +import ATrade.Broker.Protocol +import ATrade.Types +import Network.Connection +import Network.HTTP.Client +import Network.HTTP.Client.TLS -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text.Format -import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Language.Haskell.Printf withTelegramTradeSink apitoken chatId f = do killMv <- newEmptyMVar @@ -42,14 +43,14 @@ sinkThread apitoken chatId killMv chan = do whileM_ (not <$> wasKilled) $ do maybeTrade <- BC.tryReadChan chan case maybeTrade of - Just trade -> sendMessage man apitoken chatId $ format "Trade: {} {} of {} at {} for {} ({}/{})" - (show (tradeOperation trade), - show (tradeQuantity trade), - tradeSecurity trade, - show (tradePrice trade), - tradeAccount trade, - (strategyId . tradeSignalId) trade, - (signalName . tradeSignalId) trade) + Just trade -> sendMessage man apitoken chatId $ [t|Trade: %? %? of %? at %? for %? (%?/%?)|] + (show $ tradeOperation trade) + (tradeQuantity trade) + (tradeSecurity trade) + (show $ tradePrice trade) + (tradeAccount trade) + ((strategyId . tradeSignalId) trade) + ((signalName . tradeSignalId) trade) Nothing -> threadDelay 1000000 where tlsSettings = TLSSettingsSimple { settingDisableCertificateValidation = True, settingDisableSession = False, settingUseServerName = False } @@ -75,4 +76,4 @@ sinkThread apitoken chatId killMv chan = do stopSinkThread killMv threadId = putMVar killMv () >> killThread threadId - + diff --git a/test/MockBroker.hs b/test/MockBroker.hs index a40b77b..f5043ea 100644 --- a/test/MockBroker.hs +++ b/test/MockBroker.hs @@ -7,17 +7,18 @@ module MockBroker ( mkMockBroker ) where -import ATrade.Types -import ATrade.Broker.Protocol -import ATrade.Broker.Server -import ATrade.Util -import Data.IORef -import qualified Data.List as L +import ATrade.Broker.Backend +import ATrade.Broker.Protocol +import ATrade.Broker.Server +import ATrade.Types +import ATrade.Util +import Data.IORef +import qualified Data.List as L data MockBrokerState = MockBrokerState { - orders :: [Order], - cancelledOrders :: [Order], - notificationCallback :: Maybe (Notification -> IO ()) + orders :: [Order], + cancelledOrders :: [Order], + notificationCallback :: Maybe (BrokerBackendNotification -> IO ()) } mockSubmitOrder :: IORef MockBrokerState -> Order -> IO () @@ -25,17 +26,17 @@ mockSubmitOrder state order = do atomicMapIORef state (\s -> s { orders = submittedOrder : orders s }) maybeCb <- notificationCallback <$> readIORef state case maybeCb of - Just cb -> cb $ OrderNotification (orderId order) Submitted + Just cb -> cb $ BackendOrderNotification (orderId order) Submitted Nothing -> return () where submittedOrder = order { orderState = Submitted } -mockCancelOrder :: IORef MockBrokerState -> OrderId -> IO Bool +mockCancelOrder :: IORef MockBrokerState -> OrderId -> IO () mockCancelOrder state oid = do ors <- orders <$> readIORef state case L.find (\o -> orderId o == oid) ors of - Just order -> atomicModifyIORef' state (\s -> (s { cancelledOrders = order : cancelledOrders s}, True)) - Nothing -> return False + Just order -> atomicModifyIORef' state (\s -> (s { cancelledOrders = order : cancelledOrders s}, ())) + Nothing -> return () mockStopBroker :: IORef MockBrokerState -> IO () mockStopBroker state = return () @@ -48,11 +49,11 @@ mkMockBroker accs = do notificationCallback = Nothing } - return (BrokerInterface { + return (BrokerBackend { accounts = accs, setNotificationCallback = \cb -> atomicMapIORef state (\s -> s { notificationCallback = cb }), submitOrder = mockSubmitOrder state, cancelOrder = mockCancelOrder state, - stopBroker = mockStopBroker state + stop = mockStopBroker state }, state) diff --git a/test/TestBrokerServer.hs b/test/TestBrokerServer.hs index f477553..d0a09c3 100644 --- a/test/TestBrokerServer.hs +++ b/test/TestBrokerServer.hs @@ -1,28 +1,30 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module TestBrokerServer ( unitTests ) where -import Test.Tasty -import Test.Tasty.HUnit - -import ATrade.Types -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import ATrade.Broker.Server -import ATrade.Broker.Protocol -import qualified Data.Text as T -import Control.Concurrent hiding (writeChan) -import Control.Exception -import System.ZMQ4 -import Data.Aeson -import Data.Time.Clock -import Data.Time.Calendar -import Data.IORef -import Data.UUID as U -import Data.UUID.V4 as UV4 -import MockBroker +import Test.Tasty +import Test.Tasty.HUnit + +import ATrade.Broker.Backend +import ATrade.Broker.Protocol +import ATrade.Broker.Server +import ATrade.Types +import Control.Concurrent hiding (writeChan) +import Control.Exception +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.IORef +import qualified Data.Text as T +import Data.Time.Calendar +import Data.Time.Clock +import Data.UUID as U +import Data.UUID.V4 as UV4 +import MockBroker +import System.ZMQ4 unitTests :: TestTree unitTests = testGroup "Broker.Server" [testBrokerServerStartStop @@ -32,8 +34,7 @@ unitTests = testGroup "Broker.Server" [testBrokerServerStartStop , testBrokerServerCancelUnknownOrder , testBrokerServerCorruptedPacket , testBrokerServerGetNotifications - , testBrokerServerDuplicateRequest - , testBrokerServerTradeSink ] + , testBrokerServerDuplicateRequest ] -- -- Few helpers @@ -55,6 +56,7 @@ connectAndSendOrder step sock order ep = do defaultOrder :: Order defaultOrder = mkOrder { + orderId = 25, orderAccountId = "demo", orderSecurity = "FOO", orderPrice = Market, @@ -68,7 +70,7 @@ makeTestTradeSink = do return (ref, f ref) where f ref t = writeIORef ref $ Just t - + -- -- Tests @@ -81,12 +83,12 @@ testBrokerServerStartStop = testCase "Broker Server starts and stops" $ withCont stopBrokerServer broS) testBrokerServerSubmitOrder :: TestTree -testBrokerServerSubmitOrder = testCaseSteps "Broker Server submits order" $ \step -> withContext (\ctx -> do +testBrokerServerSubmitOrder = testCaseSteps "Broker Server submits order" $ \step -> withContext $ \ctx -> do step "Setup" (mockBroker, broState) <- mkMockBroker ["demo"] ep <- makeEndpoint - bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ -> do - withSocket ctx Req (\sock -> do + bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer $ \_ -> do + withSocket ctx Req $ \sock -> do connectAndSendOrder step sock defaultOrder ep step "Checking that order is submitted to BrokerInterface" @@ -97,10 +99,8 @@ testBrokerServerSubmitOrder = testCaseSteps "Broker Server submits order" $ \ste resp <- decode . BL.fromStrict <$> receive sock case resp of Just (ResponseOrderSubmitted _) -> return () - Just _ -> assertFailure "Invalid response" - Nothing -> assertFailure "Invalid response" - - ))) + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" testBrokerServerSubmitOrderToUnknownAccount :: TestTree testBrokerServerSubmitOrderToUnknownAccount = testCaseSteps "Broker Server returns error if account is unknown" $ @@ -116,27 +116,28 @@ testBrokerServerSubmitOrderToUnknownAccount = testCaseSteps "Broker Server retur resp <- decode . BL.fromStrict <$> receive sock case resp of Just (ResponseError _) -> return () - Just _ -> assertFailure "Invalid response" - Nothing -> assertFailure "Invalid response" + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" ))) testBrokerServerCancelOrder :: TestTree testBrokerServerCancelOrder = testCaseSteps "Broker Server: submitted order cancellation" $ - \step -> withContext (\ctx -> do + \step -> withContext $ \ctx -> do step "Setup" ep <- makeEndpoint (mockBroker, broState) <- mkMockBroker ["demo"] - bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ -> - withSocket ctx Req (\sock -> do + bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer $ \_ -> + withSocket ctx Req $ \sock -> do connectAndSendOrder step sock defaultOrder ep - (Just (ResponseOrderSubmitted orderId)) <- decode . BL.fromStrict <$> receive sock + (Just (ResponseOrderSubmitted localOrderId)) <- decode . BL.fromStrict <$> receive sock + localOrderId @=? (orderId defaultOrder) step "Sending order cancellation request" - send sock [] (BL.toStrict . encode $ RequestCancelOrder 2 "identity" orderId) + send sock [] (BL.toStrict . encode $ RequestCancelOrder 2 "identity" localOrderId) threadDelay 10000 - step "Checking that order is cancelled in BrokerInterface" + step "Checking that order is cancelled in BrokerBackend" s <- readIORef broState (length . cancelledOrders) s @?= 1 @@ -144,9 +145,8 @@ testBrokerServerCancelOrder = testCaseSteps "Broker Server: submitted order canc resp <- decode . BL.fromStrict <$> receive sock case resp of Just (ResponseOrderCancelled _) -> return () - Just _ -> assertFailure "Invalid response" - Nothing -> assertFailure "Invalid response" - ))) + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" testBrokerServerCancelUnknownOrder :: TestTree testBrokerServerCancelUnknownOrder = testCaseSteps "Broker Server: order cancellation: error if order is unknown" $ @@ -167,8 +167,8 @@ testBrokerServerCancelUnknownOrder = testCaseSteps "Broker Server: order cancell resp <- decode . BL.fromStrict <$> receive sock case resp of Just (ResponseError _) -> return () - Just _ -> assertFailure "Invalid response" - Nothing -> assertFailure "Invalid response" + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" ))) testBrokerServerCorruptedPacket :: TestTree @@ -190,30 +190,33 @@ testBrokerServerCorruptedPacket = testCaseSteps "Broker Server: corrupted packet resp <- decode . BL.fromStrict <$> receive sock case resp of Just (ResponseError _) -> return () - Just _ -> assertFailure "Invalid response" - Nothing -> assertFailure "Invalid response" + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" ))) where corrupt = B.drop 5 testBrokerServerGetNotifications :: TestTree testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications request" $ - \step -> withContext (\ctx -> do + \step -> withContext $ \ctx -> do step "Setup" ep <- makeEndpoint (mockBroker, broState) <- mkMockBroker ["demo"] - bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ -> - withSocket ctx Req (\sock -> do + bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer $ \_ -> + withSocket ctx Req $ \sock -> do -- We have to actually submit order, or else server won't know that we should -- be notified about this order connectAndSendOrder step sock defaultOrder ep - (Just (ResponseOrderSubmitted orderId)) <- decode . BL.fromStrict <$> receive sock + (Just (ResponseOrderSubmitted localOrderId)) <- decode . BL.fromStrict <$> receive sock + localOrderId @=? orderId defaultOrder threadDelay 10000 + globalOrderId <- orderId . head . orders <$> readIORef broState + (Just cb) <- notificationCallback <$> readIORef broState - cb (OrderNotification orderId Executed) + cb (BackendOrderNotification globalOrderId Executed) let trade = Trade { - tradeOrderId = orderId, + tradeOrderId = globalOrderId, tradePrice = 19.82, tradeQuantity = 1, tradeVolume = 1982, @@ -224,7 +227,7 @@ testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications r tradeTimestamp = UTCTime (fromGregorian 2016 9 28) 16000, tradeCommission = 0, tradeSignalId = SignalId "Foo" "bar" "baz" } - cb (TradeNotification trade) + cb (BackendTradeNotification trade) step "Sending notifications request" send sock [] (BL.toStrict . encode $ RequestNotifications 2 "identity") @@ -241,9 +244,10 @@ testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications r length ns @=? 3 let (OrderNotification oid newstate) = ns !! 1 let (TradeNotification newtrade) = ns !! 2 - orderId @=? oid + localOrderId @=? oid Executed @=? newstate - trade @=? newtrade + trade { tradeOrderId = localOrderId } @=? newtrade + Just _ -> assertFailure "Invalid response" Nothing -> assertFailure "Invalid response" @@ -258,21 +262,15 @@ testBrokerServerGetNotifications = testCaseSteps "Broker Server: notifications r 0 @=? length ns Just _ -> assertFailure "Invalid response" Nothing -> assertFailure "Invalid response" - ))) testBrokerServerDuplicateRequest :: TestTree -testBrokerServerDuplicateRequest = testCaseSteps "Broker Server: duplicate request" $ \step -> withContext (\ctx -> do - putStrLn "epsilon" +testBrokerServerDuplicateRequest = testCaseSteps "Broker Server: duplicate request" $ \step -> withContext $ \ctx -> do step "Setup" (mockBroker, broState) <- mkMockBroker ["demo"] ep <- makeEndpoint - putStrLn "delta" - bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer (\_ -> do - putStrLn "gamma" - withSocket ctx Req (\sock -> do - putStrLn "alpha" + bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer $ \_ -> do + withSocket ctx Req $ \sock -> do connectAndSendOrder step sock defaultOrder ep - putStrLn "beta" step "Reading response" (Just (ResponseOrderSubmitted orderId)) <- decode . BL.fromStrict <$> receive sock @@ -289,11 +287,10 @@ testBrokerServerDuplicateRequest = testCaseSteps "Broker Server: duplicate reque resp <- decode . BL.fromStrict <$> receive sock case resp of Just (ResponseOrderSubmitted oid) -> orderId @?= oid - Just _ -> assertFailure "Invalid response" - Nothing -> assertFailure "Invalid response" - - ))) + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" +{- testBrokerServerTradeSink :: TestTree testBrokerServerTradeSink = testCaseSteps "Broker Server: sends trades to trade sink" $ \step -> withContext (\ctx -> do step "Setup" @@ -319,7 +316,7 @@ testBrokerServerTradeSink = testCaseSteps "Broker Server: sends trades to trade tradeTimestamp = UTCTime (fromGregorian 2016 9 28) 16000, tradeCommission = 0, tradeSignalId = SignalId "Foo" "bar" "baz" } - cb (TradeNotification trade) + cb (BackendTradeNotification trade) threadDelay 100000 step "Testing" @@ -329,3 +326,4 @@ testBrokerServerTradeSink = testCaseSteps "Broker Server: sends trades to trade trade' @?= trade _ -> assertFailure "Invalid trade in sink" ))) +-} From 54b3aaecd5cddce52da936c7e70f624b6210fe9f Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Fri, 9 Jul 2021 13:53:32 +0700 Subject: [PATCH 4/4] BrokerServer: test order submission from different endpoints --- test/TestBrokerServer.hs | 41 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/test/TestBrokerServer.hs b/test/TestBrokerServer.hs index d0a09c3..bfa47a4 100644 --- a/test/TestBrokerServer.hs +++ b/test/TestBrokerServer.hs @@ -29,6 +29,7 @@ import System.ZMQ4 unitTests :: TestTree unitTests = testGroup "Broker.Server" [testBrokerServerStartStop , testBrokerServerSubmitOrder + , testBrokerServerSubmitOrderDifferentIdentities , testBrokerServerSubmitOrderToUnknownAccount , testBrokerServerCancelOrder , testBrokerServerCancelUnknownOrder @@ -54,6 +55,15 @@ connectAndSendOrder step sock order ep = do send sock [] (BL.toStrict . encode $ RequestSubmitOrder 1 "identity" order) threadDelay 10000 +connectAndSendOrderWithIdentity :: (Sender a) => (String -> IO ()) -> Socket a -> Order -> ClientIdentity -> T.Text -> IO () +connectAndSendOrderWithIdentity step sock order clientIdentity ep = do + step "Connecting" + connect sock (T.unpack ep) + + step $ "Sending request for identity: " ++ show clientIdentity + send sock [] (BL.toStrict . encode $ RequestSubmitOrder 1 clientIdentity order) + threadDelay 10000 + defaultOrder :: Order defaultOrder = mkOrder { orderId = 25, @@ -102,6 +112,37 @@ testBrokerServerSubmitOrder = testCaseSteps "Broker Server submits order" $ \ste Just _ -> assertFailure "Invalid response" Nothing -> assertFailure "Invalid response" +testBrokerServerSubmitOrderDifferentIdentities :: TestTree +testBrokerServerSubmitOrderDifferentIdentities = testCaseSteps "Broker Server submits order: different identities" $ \step -> withContext $ \ctx -> do + step "Setup" + (mockBroker, broState) <- mkMockBroker ["demo"] + ep <- makeEndpoint + let orderId1 = 42 + let orderId2 = 76 + bracket (startBrokerServer [mockBroker] ctx ep [] defaultServerSecurityParams) stopBrokerServer $ \_ -> do + withSocket ctx Req $ \sock1 -> do + withSocket ctx Req $ \sock2 -> do + connectAndSendOrderWithIdentity step sock1 defaultOrder {orderId = orderId1} "identity1" ep + connectAndSendOrderWithIdentity step sock2 defaultOrder {orderId = orderId2} "identity2" ep + + step "Checking that orders are submitted to BrokerInterface" + s <- readIORef broState + (length . orders) s @?= 2 + + step "Reading response for identity1" + resp <- decode . BL.fromStrict <$> receive sock1 + case resp of + Just (ResponseOrderSubmitted localOrderId) -> localOrderId @=? orderId1 + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" + + step "Reading response for identity2" + resp <- decode . BL.fromStrict <$> receive sock2 + case resp of + Just (ResponseOrderSubmitted localOrderId) -> localOrderId @=? orderId2 + Just _ -> assertFailure "Invalid response" + Nothing -> assertFailure "Invalid response" + testBrokerServerSubmitOrderToUnknownAccount :: TestTree testBrokerServerSubmitOrderToUnknownAccount = testCaseSteps "Broker Server returns error if account is unknown" $ \step -> withContext (\ctx -> do