WIP

src/ATrade/Broker/Protocol.hs

@@ -1,9 +1,14 @@
-{-# LANGUAGE OverloadedStrings, MultiWayIf, RecordWildCards #-}
+{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 module ATrade.Broker.Protocol (
   BrokerServerRequest(..),
   BrokerServerResponse(..),
   Notification(..),
+  NotificationSqnum(..),
+  nextSqnum,
   notificationOrderId,
   RequestSqnum(..),
   requestSqnum,
@@ -12,22 +17,65 @@ module ATrade.Broker.Protocol (
   ClientIdentity(..)
 ) where
 
+import           ATrade.Types
+import           Control.Applicative
 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 qualified Data.HashMap.Strict     as HM
 import           Data.Int
-import Data.Time.Clock
+import qualified Data.Text               as T
+import           Data.Text.Encoding
 import           Data.Time.Calendar
-import ATrade.Types
-import Text.Parsec
+import           Data.Time.Clock
+import           Language.Haskell.Printf
+import           Text.Parsec             hiding ((<|>))
 
 type ClientIdentity = T.Text
 type RequestSqnum = Int64
 
+newtype NotificationSqnum = NotificationSqnum { unNotificationSqnum :: Int64 }
+  deriving (Eq, Show)
+
+nextSqnum :: NotificationSqnum -> NotificationSqnum
+nextSqnum (NotificationSqnum n) = NotificationSqnum (n + 1)
+
+data Notification = OrderNotification NotificationSqnum OrderId OrderState | TradeNotification NotificationSqnum Trade
+  deriving (Eq, Show)
+
+notificationSqnum :: Notification -> NotificationSqnum
+notificationSqnum (OrderNotification sqnum _ _) = sqnum
+notificationSqnum (TradeNotification sqnum _)   = sqnum
+
+notificationOrderId :: Notification -> OrderId
+notificationOrderId (OrderNotification _ oid _) = oid
+notificationOrderId (TradeNotification _ trade) = tradeOrderId trade
+
+instance FromJSON Notification where
+  parseJSON = withObject "notification" $ \obj -> parseNotification obj
+    where
+      parseNotification obj =
+        case HM.lookup "notification-sqnum" obj of
+          Just (Number sqnum) -> parseTrade (NotificationSqnum $ truncate sqnum) obj <|>
+                                 parseOrder (NotificationSqnum $ truncate sqnum) obj <|>
+                                 fail "Can't parse notification"
+          Just _ -> fail "Invalid sqnum"
+          Nothing -> fail "Unable to lookup notification sqnum"
+      parseTrade sqnum obj = case HM.lookup "trade" obj of
+        Just val -> TradeNotification sqnum <$> (parseJSON val)
+        Nothing  -> fail "Can't parse trade"
+      parseOrder sqnum obj = case HM.lookup "order-state" obj of
+        Just v -> withObject "object" (\os -> do
+          oid <- os .: "order-id"
+          ns <- os .: "new-state"
+          return $ OrderNotification sqnum oid ns) v
+        Nothing -> fail "Should be order-state"
+
+instance ToJSON Notification where
+  toJSON (OrderNotification sqnum oid newState) = object [ "notification-sqnum" .= toJSON (unNotificationSqnum sqnum), "order-state" .= object [ "order-id" .= oid, "new-state" .= newState ] ]
+  toJSON (TradeNotification sqnum trade) = object [ "notification-sqnum" .= toJSON (unNotificationSqnum sqnum), "trade" .= toJSON trade ]
+
+
 data BrokerServerRequest = RequestSubmitOrder RequestSqnum ClientIdentity Order
   | RequestCancelOrder RequestSqnum ClientIdentity OrderId
   | RequestNotifications RequestSqnum ClientIdentity
@@ -85,7 +133,8 @@ instance FromJSON BrokerServerResponse where
            ResponseNotifications <$> parseJSON notifications
        | HM.member "error" obj -> do
            error <- obj .: "error"
-        ResponseError <$> parseJSON error)
+           ResponseError <$> parseJSON error
+       | otherwise -> fail "Unable to parse BrokerServerResponse")
 
 instance ToJSON BrokerServerResponse where
   toJSON (ResponseOrderSubmitted oid) = object [ "order-id" .= oid ]
@@ -93,32 +142,6 @@ instance ToJSON BrokerServerResponse where
   toJSON (ResponseNotifications notifications) = object [ "notifications" .= notifications ]
   toJSON (ResponseError errorMessage) = object [ "error" .= errorMessage ]
 
-data Notification = OrderNotification OrderId OrderState | TradeNotification Trade
-  deriving (Eq, Show)
-
-notificationOrderId :: Notification -> OrderId
-notificationOrderId (OrderNotification oid _) = oid
-notificationOrderId (TradeNotification trade) = tradeOrderId trade
-
-instance FromJSON Notification where
-  parseJSON n = withObject "notification" (\obj ->
-    case HM.lookup "trade" obj of
-      Just v -> parseTrade v
-      Nothing -> parseOrder n) n
-    where
-      parseTrade v = TradeNotification <$> parseJSON v
-      parseOrder (Object o) = case HM.lookup "order-state" o of
-        Just v -> withObject "object" (\os -> do
-          oid <- os .: "order-id"
-          ns <- os .: "new-state"
-          return $ OrderNotification oid ns) v
-        Nothing -> fail "Should be order-state"
-      parseOrder _ = fail "Unable to parse order state"
-
-instance ToJSON Notification where
-  toJSON (OrderNotification oid newState) = object ["order-state" .= object [ "order-id" .= oid, "new-state" .= newState] ]
-  toJSON (TradeNotification trade) = object ["trade" .= toJSON trade]
-
 data TradeSinkMessage = TradeSinkHeartBeat | TradeSinkTrade {
   tsAccountId     :: T.Text,
   tsSecurity      :: T.Text,
@@ -153,7 +176,7 @@ 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

test/ArbitraryInstances.hs

@@ -21,6 +21,9 @@ notTooBig x = abs x < 100000000
 
 arbitraryTickerId = arbitrary `suchThat` (T.all (/= ':'))
 
+instance Arbitrary NotificationSqnum where
+  arbitrary = NotificationSqnum <$> arbitrary
+
 instance Arbitrary Tick where
   arbitrary = Tick <$>
     arbitraryTickerId <*>
@@ -96,10 +99,11 @@ instance Arbitrary Notification where
     t <- choose (1, 2) :: Gen Int
     if t == 1
       then do
+        sqnum <- arbitrary
         oid <- arbitrary
         state <- arbitrary
-        return $ OrderNotification oid state
-      else TradeNotification <$> arbitrary
+        return $ OrderNotification sqnum oid state
+      else TradeNotification <$> arbitrary <*> arbitrary
 
 instance Arbitrary BrokerServerRequest where
   arbitrary = do

test/MockBroker.hs

@@ -7,9 +7,9 @@ module MockBroker (
   mkMockBroker
 ) where
 
-import ATrade.Types
 import           ATrade.Broker.Protocol
 import           ATrade.Broker.Server
+import           ATrade.Types
 import           ATrade.Util
 import           Data.IORef
 import qualified Data.List              as L
@@ -17,15 +17,16 @@ import qualified Data.List as L
 data MockBrokerState = MockBrokerState {
   orders               :: [Order],
   cancelledOrders      :: [Order],
-  notificationCallback :: Maybe (Notification -> IO ())
+  notificationCallback :: Maybe (Notification -> IO ()),
+  sqnum                :: NotificationSqnum
 }
 
 mockSubmitOrder :: IORef MockBrokerState -> Order -> IO ()
 mockSubmitOrder state order = do
-  atomicMapIORef state (\s -> s { orders = submittedOrder : orders s })
+  sqnum <- atomicModifyIORef' state (\s -> (s { orders = submittedOrder : orders s, sqnum = nextSqnum (sqnum s) }, sqnum s))
   maybeCb <- notificationCallback <$> readIORef state
   case maybeCb of
-    Just cb -> cb $ OrderNotification (orderId order) Submitted
+    Just cb -> cb $ OrderNotification sqnum (orderId order) Submitted
     Nothing -> return ()
   where
     submittedOrder = order { orderState = Submitted }