Api.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{- | Binance.org API requests & responses.

-}
module Console.BnbStaking.Api
    ( -- * Rewards
      getAllRewards
    , Reward(..)
      -- * Low-Level Requests & Responses
    , Endpoint(..)
    , makeRequest
    , RewardResponse(..)
    ) where

import           Control.Monad                  ( forM )
import           Data.Aeson                     ( (.:)
                                                , FromJSON(..)
                                                , withObject
                                                )
import           Data.List                      ( sortOn )
import           Data.Maybe                     ( fromMaybe )
import           Data.Scientific                ( Scientific )
import           Data.Time                      ( UTCTime
                                                , defaultTimeLocale
                                                , parseTimeM
                                                )
import           GHC.Generics                   ( Generic )
import           Network.HTTP.Req               ( (/:)
                                                , (=:)
                                                , GET(..)
                                                , MonadHttp
                                                , NoReqBody(..)
                                                , Scheme(Https)
                                                , Url
                                                , https
                                                , jsonResponse
                                                , req
                                                , responseBody
                                                )

import qualified Data.Text                     as T


-- | Fetch all rewards for the given Delegator PubKey.
getAllRewards :: MonadHttp m => T.Text -> m [Reward]
getAllRewards pubKey = do
    let pageSize  = 50
        jPageSize = Just pageSize
    initialResp <- makeRequest $ GetRewards pubKey jPageSize Nothing
    let rewardCount = rrTotal initialResp
    remainingRewards <- if rewardCount < pageSize
        then return []
        else
            fmap concat
            . forM [pageSize, pageSize * 2 .. rewardCount]
            $ \(Just -> offset) ->
                  rrRewards <$> makeRequest (GetRewards pubKey jPageSize offset)
    return . sortResults $ rrRewards initialResp <> remainingRewards
  where
    sortResults :: [Reward] -> [Reward]
    sortResults = sortOn rRewardTime


-- | Represents all endpoints of the binance.org api, as well as their
-- respective response data.
data Endpoint a where
    GetRewards ::T.Text -> Maybe Integer -> Maybe Integer -> Endpoint RewardResponse

-- | Make a request to an endpoint.
makeRequest :: MonadHttp m => Endpoint a -> m a
makeRequest e = case e of
    GetRewards _ mbLimit mbOffset -> responseBody <$> req
        GET
        url
        NoReqBody
        jsonResponse
        (("limit" =: fromMaybe 20 mbLimit) <> ("offset" =: fromMaybe 0 mbOffset)
        )
  where
    url :: Url 'Https
    url = case e of
        GetRewards pubKey _ _ ->
            baseUrl
                /: "staking"
                /: "chains"
                /: "bsc"
                /: "delegators"
                /: pubKey
                /: "rewards"
    baseUrl :: Url 'Https
    baseUrl = https "api.binance.org" /: "v1"


-- | Response of requesting a delegator's rewards.
data RewardResponse = RewardResponse
    { rrTotal   :: Integer
    -- ^ Total number of rewards.
    , rrRewards :: [Reward]
    -- ^ Rewards in this page.
    }
    deriving (Show, Read, Eq, Generic)

instance FromJSON RewardResponse where
    parseJSON = withObject "RewardResponse" $ \o -> do
        rrTotal   <- o .: "total"
        rrRewards <- o .: "rewardDetails"
        return $ RewardResponse { .. }


-- | A single staking reward.
data Reward = Reward
    { rValidatorName    :: T.Text
    , rValidatorAddress :: T.Text
    , rDelegator        :: T.Text
    , rChainId          :: T.Text
    -- ^ Always @bsc@ at the moment - no testnet rewards supported.
    , rHeight           :: Integer
    , rReward           :: Scientific
    , rRewardTime       :: UTCTime
    }
    deriving (Show, Read, Eq, Generic)

instance FromJSON Reward where
    parseJSON = withObject "Reward" $ \o -> do
        rValidatorName    <- o .: "valName"
        rValidatorAddress <- o .: "validator"
        rDelegator        <- o .: "delegator"
        rChainId          <- o .: "chainId"
        rHeight           <- o .: "height"
        rReward           <- o .: "reward"
        rRewardTime       <- o .: "rewardTime" >>= parseTimeM True
                                                              defaultTimeLocale
                                                              "%FT%T%Q%Ez"
        return $ Reward { .. }