From 383858e121a6b661abc60177a1a8745ff3a18bf1 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Tue, 27 Sep 2016 20:55:48 +0700 Subject: [PATCH] BrokerServer Protocol: Request/response encoding --- libatrade.cabal | 6 ++ src/ATrade/Broker/Protocol.hs | 55 ++++++++++++++-- src/ATrade/Types.hs | 3 +- test/ArbitraryInstances.hs | 118 ++++++++++++++++++++++++++++++++++ test/TestBrokerProtocol.hs | 27 +++++++- test/TestTypes.hs | 76 +--------------------- 6 files changed, 203 insertions(+), 82 deletions(-) create mode 100644 test/ArbitraryInstances.hs diff --git a/libatrade.cabal b/libatrade.cabal index 5c293e6..0d90a6d 100644 --- a/libatrade.cabal +++ b/libatrade.cabal @@ -17,6 +17,7 @@ library hs-source-dirs: src exposed-modules: ATrade.Types , ATrade.QuoteSource.Server + , ATrade.Broker.Protocol build-depends: base >= 4.7 && < 5 , Decimal , time @@ -28,6 +29,7 @@ library , BoundedChan , hslogger , zeromq4-haskell + , unordered-containers default-language: Haskell2010 executable libatrade-exe @@ -66,6 +68,10 @@ test-suite libatrade-test , monad-loops ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 + other-modules: ArbitraryInstances + , TestBrokerProtocol + , TestQuoteSourceServer + , TestTypes source-repository head type: git diff --git a/src/ATrade/Broker/Protocol.hs b/src/ATrade/Broker/Protocol.hs index 1d075bc..a6679f7 100644 --- a/src/ATrade/Broker/Protocol.hs +++ b/src/ATrade/Broker/Protocol.hs @@ -1,22 +1,69 @@ +{-# LANGUAGE OverloadedStrings, MultiWayIf #-} module ATrade.Broker.Protocol ( + BrokerServerRequest(..), + BrokerServerResponse(..), + Notification(..) ) where import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Data.Aeson +import Data.Aeson.Types import Data.Int import ATrade.Types type RequestSqnum = Int64 -data BrokerServerRequest = RequestSubmitOrder Order - | RequestCancelOrder OrderId - | RequestNotifications +data BrokerServerRequest = RequestSubmitOrder RequestSqnum Order + | RequestCancelOrder RequestSqnum OrderId + | RequestNotifications RequestSqnum + deriving (Eq, Show) + +instance FromJSON BrokerServerRequest where + parseJSON = withObject "object" (\obj -> do + sqnum <- obj .: "request-sqnum" + parseRequest sqnum obj) + where + parseRequest :: RequestSqnum -> Object -> Parser BrokerServerRequest + parseRequest sqnum obj + | HM.member "order" obj = do + order <- obj .: "order" + RequestSubmitOrder sqnum <$> parseJSON order + | HM.member "cancel-order" obj = do + orderId <- obj .: "cancel-order" + RequestCancelOrder sqnum <$> parseJSON orderId + | HM.member "request-notifications" obj = return (RequestNotifications sqnum) + +instance ToJSON BrokerServerRequest where + toJSON (RequestSubmitOrder sqnum order) = object ["request-sqnum" .= sqnum, + "order" .= order ] + toJSON (RequestCancelOrder sqnum oid) = object ["request-sqnum" .= sqnum, + "cancel-order" .= oid ] + toJSON (RequestNotifications sqnum) = object ["request-sqnum" .= sqnum, + "request-notifications" .= ("" :: T.Text) ] data BrokerServerResponse = ResponseOrderSubmitted OrderId - | ResponseOrderCancelled + | ResponseOrderCancelled OrderId | ResponseNotifications [Notification] + deriving (Eq, Show) + +instance FromJSON BrokerServerResponse where + parseJSON = withObject "object" (\obj -> + if | HM.member "order-id" obj -> do + oid <- obj .: "order-id" + return $ ResponseOrderSubmitted oid + | HM.member "order-cancelled" obj -> do + oid <- obj .: "order-cancelled" + return $ ResponseOrderCancelled oid + | HM.member "notifications" obj -> do + notifications <- obj .: "notifications" + ResponseNotifications <$> parseJSON notifications) + +instance ToJSON BrokerServerResponse where + toJSON (ResponseOrderSubmitted oid) = object [ "order-id" .= oid ] + toJSON (ResponseOrderCancelled oid) = object [ "order-cancelled" .= oid ] + toJSON (ResponseNotifications notifications) = object [ "notifications" .= notifications ] data Notification = OrderNotification OrderId OrderState | TradeNotification Trade deriving (Eq, Show) diff --git a/src/ATrade/Types.hs b/src/ATrade/Types.hs index 7ece555..f0300d3 100644 --- a/src/ATrade/Types.hs +++ b/src/ATrade/Types.hs @@ -10,7 +10,8 @@ module ATrade.Types ( Operation(..), OrderState(..), Order(..), - Trade(..) + Trade(..), + OrderId(..) ) where import Control.Monad diff --git a/test/ArbitraryInstances.hs b/test/ArbitraryInstances.hs new file mode 100644 index 0000000..d8f7a02 --- /dev/null +++ b/test/ArbitraryInstances.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} + +module ArbitraryInstances ( +) where + + +import Test.Tasty +import Test.Tasty.SmallCheck as SC +import Test.Tasty.QuickCheck as QC +import Test.QuickCheck.Instances hiding (Text) + +import ATrade.Types +import ATrade.Broker.Protocol + +import Data.Decimal +import Data.Scientific +import Data.Time.Clock +import Data.Time.Calendar + +notTooBig x = abs x < 1000000000000 + +instance Arbitrary Tick where + arbitrary = Tick <$> + arbitrary <*> + arbitrary <*> + arbitraryTimestamp <*> + (roundTo 9 <$> (arbitrary `suchThat` notTooBig)) <*> + arbitrary + where + arbitraryTimestamp = do + y <- choose (1970, 2050) + m <- choose (1, 12) + d <- choose (1, 31) + + sec <- secondsToDiffTime <$> choose (0, 86399) + + return $ UTCTime (fromGregorian y m d) sec + +instance Arbitrary DataType where + arbitrary = toEnum <$> choose (1, 10) + +instance Arbitrary Decimal where + arbitrary = realFracToDecimal 10 <$> (arbitrary :: Gen Scientific) + +instance Arbitrary SignalId where + arbitrary = SignalId <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary OrderPrice where + arbitrary = do + v <- choose (1, 4) :: Gen Int + if | v == 1 -> return Market + | 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" + +instance Arbitrary Operation where + arbitrary = elements [Buy, Sell] + +instance Arbitrary OrderState where + arbitrary = elements [Unsubmitted, + Submitted, + PartiallyExecuted, + Executed, + Cancelled, + Rejected, + OrderError ] + +instance Arbitrary Order where + arbitrary = Order <$> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary + +instance Arbitrary Trade where + arbitrary = Trade <$> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary + +instance Arbitrary Notification where + arbitrary = do + t <- choose (1, 2) :: Gen Int + if t == 1 + then do + oid <- arbitrary + state <- arbitrary + return $ OrderNotification oid state + else TradeNotification <$> arbitrary + +instance Arbitrary BrokerServerRequest where + arbitrary = do + t <- choose (1, 3) :: Gen Int + if | t == 1 -> RequestSubmitOrder <$> arbitrary <*> arbitrary + | t == 2 -> RequestCancelOrder <$> arbitrary <*> arbitrary + | t == 3 -> RequestNotifications <$> arbitrary + +instance Arbitrary BrokerServerResponse where + arbitrary = do + t <- choose (1, 3) :: Gen Int + if | t == 1 -> ResponseOrderSubmitted <$> arbitrary + | t == 2 -> ResponseOrderCancelled <$> arbitrary + | t == 3 -> ResponseNotifications <$> arbitrary + diff --git a/test/TestBrokerProtocol.hs b/test/TestBrokerProtocol.hs index b64e770..cdd6757 100644 --- a/test/TestBrokerProtocol.hs +++ b/test/TestBrokerProtocol.hs @@ -11,8 +11,31 @@ import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit import Test.QuickCheck.Instances hiding (Text) -import ATrade.Types import ATrade.Broker.Protocol +import ArbitraryInstances -properties = testGroup "Broker.Protocol" [] +import Data.Aeson +import Data.Decimal +import Data.Scientific + +properties = testGroup "Broker.Protocol" [ + testNotificationEncoding + , testBrokerServerRequestEncoding + , testBrokerServerResponseEncoding + ] + +testNotificationEncoding = QC.testProperty "Notification encoding" + (\v -> case (decode . encode $ v :: Maybe Notification) of + Just s -> s == v + Nothing -> False) + +testBrokerServerRequestEncoding = QC.testProperty "BrokerServerRequest encoding" + (\v -> case (decode . encode $ v :: Maybe BrokerServerRequest) of + Just s -> s == v + Nothing -> False) + +testBrokerServerResponseEncoding = QC.testProperty "BrokerServerResponse encoding" + (\v -> case (decode . encode $ v :: Maybe BrokerServerResponse) of + Just s -> s == v + Nothing -> False) diff --git a/test/TestTypes.hs b/test/TestTypes.hs index 6bcfdea..3e74b50 100644 --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -9,9 +9,9 @@ import Test.Tasty import Test.Tasty.SmallCheck as SC import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit -import Test.QuickCheck.Instances hiding (Text) import ATrade.Types +import ArbitraryInstances import Data.Aeson import Data.Aeson.Types @@ -22,80 +22,6 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Tuple.Select -notTooBig x = abs x < 1000000000000 - -instance Arbitrary Tick where - arbitrary = Tick <$> - arbitrary <*> - arbitrary <*> - arbitraryTimestamp <*> - (roundTo 9 <$> (arbitrary `suchThat` notTooBig)) <*> - arbitrary - where - arbitraryTimestamp = do - y <- choose (1970, 2050) - m <- choose (1, 12) - d <- choose (1, 31) - - sec <- secondsToDiffTime <$> choose (0, 86399) - - return $ UTCTime (fromGregorian y m d) sec - -instance Arbitrary DataType where - arbitrary = toEnum <$> choose (1, 10) - -instance Arbitrary Decimal where - arbitrary = realFracToDecimal 10 <$> (arbitrary :: Gen Scientific) - -instance Arbitrary SignalId where - arbitrary = SignalId <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary OrderPrice where - arbitrary = do - v <- choose (1, 4) :: Gen Int - if | v == 1 -> return Market - | 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" - -instance Arbitrary Operation where - arbitrary = elements [Buy, Sell] - -instance Arbitrary OrderState where - arbitrary = elements [Unsubmitted, - Submitted, - PartiallyExecuted, - Executed, - Cancelled, - Rejected, - OrderError ] - -instance Arbitrary Order where - arbitrary = Order <$> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary - -instance Arbitrary Trade where - arbitrary = Trade <$> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary <*> - arbitrary - properties = testGroup "Types" [ testTickSerialization , testSignalIdSerialization