libatrade/src/ATrade/Broker/Protocol.hs

{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}

module ATrade.Broker.Protocol (
  BrokerServerRequest(..),
  BrokerServerResponse(..),
  Notification(..),
  NotificationSqnum(..),
  nextSqnum,
  getNotificationSqnum,
  notificationOrderId,
  TradeSinkMessage(..),
  mkTradeMessage,
  ClientIdentity(..),
  RequestId(..),
  getRequestId,
  getResponseRequestId
) where

import           ATrade.Types
import           Control.Applicative     ((<|>))
import           Control.Error.Util
import           Data.Aeson
import           Data.Aeson.KeyMap       as KM
import           Data.Aeson.Types        hiding (parse)
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             hiding ((<|>))

data RequestId = RequestId Int64
  deriving (Eq, Show, Ord)

type ClientIdentity = T.Text

newtype NotificationSqnum = NotificationSqnum { unNotificationSqnum :: Int64 }
  deriving (Eq, Show, Ord)

nextSqnum :: NotificationSqnum -> NotificationSqnum
nextSqnum (NotificationSqnum n) = NotificationSqnum (n + 1)

data Notification = OrderNotification NotificationSqnum OrderId OrderState | TradeNotification NotificationSqnum Trade
  deriving (Eq, Show)

getNotificationSqnum :: Notification -> NotificationSqnum
getNotificationSqnum (OrderNotification sqnum _ _) = sqnum
getNotificationSqnum (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 KM.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 KM.lookup "trade" obj of
        Just val -> TradeNotification sqnum <$> (parseJSON val)
        Nothing  -> fail "Can't parse trade"
      parseOrder sqnum obj = case KM.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 RequestId ClientIdentity Order
  | RequestCancelOrder RequestId ClientIdentity OrderId
  | RequestNotifications RequestId ClientIdentity NotificationSqnum
  | RequestCurrentSqnum RequestId ClientIdentity
  | RequestSetClientIdentity RequestId ClientIdentity
  deriving (Eq, Show)

getRequestId :: BrokerServerRequest -> RequestId
getRequestId (RequestSubmitOrder rid _ _)     = rid
getRequestId (RequestCancelOrder rid _ _)     = rid
getRequestId (RequestNotifications rid _ _)   = rid
getRequestId (RequestCurrentSqnum rid _)      = rid
getRequestId (RequestSetClientIdentity rid _) = rid

instance FromJSON BrokerServerRequest where
  parseJSON = withObject "object" (\obj -> do
    clientIdentity <- obj .: "client-identity"
    requestId <- obj .: "request-id"
    parseRequest (RequestId requestId) clientIdentity obj)
    where
      parseRequest :: RequestId -> ClientIdentity -> Object -> Parser BrokerServerRequest
      parseRequest requestId clientIdentity obj
        | KM.member "order" obj = do
          order <- obj .: "order"
          RequestSubmitOrder requestId clientIdentity <$> parseJSON order
        | KM.member "cancel-order" obj = do
          orderId <- obj .: "cancel-order"
          RequestCancelOrder requestId clientIdentity <$> parseJSON orderId
        | KM.member "request-notifications" obj = do
            initialSqnum <- obj .: "initial-sqnum"
            return (RequestNotifications requestId clientIdentity (NotificationSqnum initialSqnum))
        | KM.member "request-current-sqnum" obj =
            return (RequestCurrentSqnum requestId clientIdentity)
        | KM.member "set-client-identity" obj =
            return (RequestSetClientIdentity requestId clientIdentity)
      parseRequest _ _ _ = fail "Invalid request object"

instance ToJSON BrokerServerRequest where
  toJSON (RequestSubmitOrder (RequestId rid) clientIdentity order) = object [
    "request-id" .= rid,
    "client-identity" .= clientIdentity,
    "order" .= order ]
  toJSON (RequestCancelOrder (RequestId rid) clientIdentity oid) = object [
    "request-id" .= rid,
    "client-identity" .= clientIdentity,
    "cancel-order" .= oid ]
  toJSON (RequestNotifications (RequestId rid) clientIdentity initialNotificationSqnum) = object [
    "request-id" .= rid,
    "client-identity" .= clientIdentity,
    "request-notifications" .= ("" :: T.Text),
    "initial-sqnum" .= unNotificationSqnum initialNotificationSqnum]
  toJSON (RequestCurrentSqnum (RequestId rid) clientIdentity) = object
    ["request-id" .= rid,
     "client-identity" .= clientIdentity,
     "request-current-sqnum" .= ("" :: T.Text) ]
  toJSON (RequestSetClientIdentity (RequestId rid) clientIdentity) = object
    ["request-id" .= rid,
     "client-identity" .= clientIdentity,
     "set-client-identity" .= ("" :: T.Text) ]

getResponseRequestId :: BrokerServerResponse -> RequestId
getResponseRequestId (ResponseOk reqId)              = reqId
getResponseRequestId (ResponseNotifications reqId _) = reqId
getResponseRequestId (ResponseCurrentSqnum reqId _)  = reqId
getResponseRequestId (ResponseError reqId _)         = reqId

data BrokerServerResponse = ResponseOk RequestId
  | ResponseNotifications RequestId [Notification]
  | ResponseCurrentSqnum RequestId NotificationSqnum
  | ResponseError RequestId T.Text
  deriving (Eq, Show)

instance FromJSON BrokerServerResponse where
  parseJSON = withObject "object" (\obj -> do
    requestId <- obj .: "request-id"
    if | KM.member "result" obj -> do
           result <- obj .: "result"
           if (result :: T.Text) == "success"
             then return $ ResponseOk (RequestId requestId)
             else do
               msg <- obj .:? "message" .!= ""
               return $ (ResponseError (RequestId requestId) msg)
       | KM.member "notifications" obj -> do
           notifications <- obj .: "notifications"
           ResponseNotifications (RequestId requestId) <$> parseJSON notifications
       | KM.member "current-sqnum" obj -> do
           rawSqnum <- obj .: "current-sqnum"
           return $ ResponseCurrentSqnum (RequestId requestId) (NotificationSqnum rawSqnum)
       | otherwise -> fail "Unable to parse BrokerServerResponse")

instance ToJSON BrokerServerResponse where
  toJSON (ResponseOk (RequestId rid)) = object [ "request-id" .= rid, "result" .= ("success" :: T.Text) ]
  toJSON (ResponseNotifications (RequestId rid) notifications) = object [ "request-id" .= rid, "notifications" .= notifications ]
  toJSON (ResponseCurrentSqnum (RequestId rid) sqnum) = object [ "request-id" .= rid, "current-sqnum" .= unNotificationSqnum sqnum ]
  toJSON (ResponseError (RequestId rid) errorMessage) = object [ "request-id" .= rid, "result" .= ("error" :: T.Text), "message" .= errorMessage ]

data TradeSinkMessage = TradeSinkHeartBeat | TradeSinkTrade {
  tsAccountId     :: T.Text,
  tsSecurity      :: T.Text,
  tsPrice         :: Double,
  tsQuantity      :: Int,
  tsVolume        :: Double,
  tsCurrency      :: T.Text,
  tsOperation     :: Operation,
  tsExecutionTime :: UTCTime,
  tsCommission    :: Double,
  tsSignalId      :: SignalId
} deriving (Show, Eq)

mkTradeMessage trade = TradeSinkTrade {
  tsAccountId = tradeAccount trade,
  tsSecurity = tradeSecurity trade,
  tsPrice = (toDouble . tradePrice) trade,
  tsQuantity = (fromInteger . tradeQuantity) trade,
  tsVolume = (toDouble . tradeVolume) trade,
  tsCurrency = tradeVolumeCurrency trade,
  tsOperation = tradeOperation trade,
  tsExecutionTime = tradeTimestamp trade,
  tsCommission = toDouble $ tradeCommission trade,
  tsSignalId = tradeSignalId trade
}
  where
    toDouble = fromRational . toRational

getHMS :: UTCTime -> (Int, Int, Int, Int)
getHMS (UTCTime _ diff) = (intsec `div` 3600, (intsec `mod` 3600) `div` 60, intsec `mod` 60, msec)
  where
    intsec = floor diff
    msec = floor $ (diff - fromIntegral intsec) * 1000

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

parseTimestamp (String t) = case hush $ parse p "" t of
  Just ts -> return ts
  Nothing -> fail "Unable to parse timestamp"
  where
    p = do
      year <- read <$> many1 digit
      char '-'
      mon <- read <$> many1 digit
      char '-'
      day <- read <$> many1 digit
      char ' '
      hour <- read <$> many1 digit
      char ':'
      min <- read <$> many1 digit
      char ':'
      sec <- read <$> many1 digit
      char '.'
      msec <- many1 digit -- TODO use msec
      return $ UTCTime (fromGregorian year mon day) (secondsToDiffTime $ hour * 3600 + min * 60 + sec)

parseTimestamp _ = fail "Unable to parse timestamp: invalid type"


instance ToJSON TradeSinkMessage where
  toJSON TradeSinkHeartBeat = object ["command" .= T.pack "heartbeat" ]
  toJSON TradeSinkTrade { .. } = object ["trade" .= object ["account" .= tsAccountId,
    "security" .= tsSecurity,
    "price" .= tsPrice,
    "quantity" .= tsQuantity,
    "volume" .= tsVolume,
    "volume-currency" .= tsCurrency,
    "operation" .= tsOperation,
    "execution-time" .= formatTimestamp tsExecutionTime,
    "commission" .= tsCommission,
    "strategy" .= strategyId tsSignalId,
    "signal-id" .= signalName tsSignalId,
    "comment" .= comment tsSignalId]]

instance FromJSON TradeSinkMessage where
  parseJSON = withObject "object" (\obj ->
    case KM.lookup "command" obj of
      Nothing  -> parseTrade obj
      Just cmd -> return TradeSinkHeartBeat)
    where
      parseTrade obj = case KM.lookup "trade" obj of
        Just (Object v) -> do
          acc <- v .: "account"
          sec <- v .: "security"
          pr <- v .: "price"
          q <- v .: "quantity"
          vol <- v .: "volume"
          cur <- v .: "volume-currency"
          op <- v .: "operation"
          commission <- v .:? "commission" .!= 0
          extime <- v .: "execution-time" >>= parseTimestamp
          strategy <- v .: "strategy"
          sid <- v .: "signal-id"
          com <- v .: "comment"
          return TradeSinkTrade {
            tsAccountId = acc,
            tsSecurity = sec,
            tsPrice = pr,
            tsQuantity = q,
            tsVolume = vol,
            tsCurrency = cur,
            tsOperation = op,
            tsExecutionTime = extime,
            tsCommission = commission,
            tsSignalId = SignalId strategy sid com }
        _ -> fail "Should've been trade object"