BrokerServer Protocol: Request/response encoding

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

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)

src/ATrade/Types.hs

@@ -10,7 +10,8 @@ module ATrade.Types (
   Operation(..),
   OrderState(..),
   Order(..),
-  Trade(..)
+  Trade(..),
+  OrderId(..)
 ) where
 
 import Control.Monad

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
+

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)
 

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