{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-| Request functions & response types for the Binance.US API
-}
module Web.Binance
(
-- * API
BinanceApiM
, runApi
, BinanceConfig(..)
, BinanceError(..)
-- * Requests
-- ** Exchange Info
, getExchangeInfo
, ExchangeInfo(..)
, SymbolDetails(..)
-- ** Trade History
, getTradeHistory
, Trade(..)
-- * Helpers
, runSignedRequest
, mkSignature
) where
import Control.Exception.Safe ( MonadCatch
, MonadThrow
, throw
, try
)
import Control.Monad.Reader ( (<=<)
, MonadIO
, MonadReader
, ReaderT
, ask
, lift
, liftIO
, runReaderT
)
import Crypto.Hash.SHA256 ( hmac )
import Data.Aeson ( (.:)
, FromJSON(..)
, eitherDecodeStrict'
, withObject
)
import Data.Function ( on )
import Data.List ( minimumBy )
import Data.Proxy ( Proxy )
import Data.Scientific ( Scientific )
import Data.Text.Encoding ( encodeUtf8 )
import Data.Time ( UTCTime
, getCurrentTime
)
import Data.Time.Clock.POSIX ( POSIXTime
, posixSecondsToUTCTime
)
import Data.Time.Format ( defaultTimeLocale
, formatTime
)
import Network.HTTP.Client ( HttpException(..)
, HttpExceptionContent(..)
, RequestBody(..)
, queryString
, requestBody
, responseStatus
)
import Network.HTTP.Req as Req
( (/:)
, (=:)
, AllowsBody
, GET(..)
, HttpBody
, HttpBodyAllowed
, HttpException(..)
, HttpMethod
, HttpResponse
, JsonResponse
, MonadHttp(..)
, NoReqBody(..)
, Option
, ProvidesBody
, Req
, Url
, defaultHttpConfig
, header
, https
, jsonResponse
, req
, reqCb
, responseBody
, runReq
)
import Network.HTTP.Types ( statusCode )
import Text.Bytedump ( hexString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
-- | Necessary configuration data for making requests to the Binance API.
data BinanceConfig = BinanceConfig
{ bcApiKey :: T.Text
-- ^ Your API Key
, bcApiSecret :: T.Text
-- ^ Your API Key's Secret
}
deriving (Show, Read, Eq, Ord)
-- | The monad in which Binance API requests are run.
newtype BinanceApiM a = BinanceApiM
{ runBinanceApiM :: ReaderT BinanceConfig Req a
} deriving (Functor, Applicative, Monad, MonadIO, MonadReader BinanceConfig, MonadThrow, MonadCatch)
-- | Run a series of API requests with the given Config.
runApi :: BinanceConfig -> BinanceApiM a -> IO a
runApi cfg = runReq defaultHttpConfig . flip runReaderT cfg . runBinanceApiM
-- | Use 'MonadHttp' from the 'Req' instance.
instance MonadHttp BinanceApiM where
handleHttpException = BinanceApiM . lift . handleHttpException
-- | Error responses from the API.
data BinanceError = BinanceError
{ beCode :: Int
, beMsg :: T.Text
}
deriving (Show, Read, Eq, Ord)
instance FromJSON BinanceError where
parseJSON = withObject "BinanceError"
$ \o -> BinanceError <$> o .: "code" <*> o .: "msg"
-- | Decode a 'BinanceError' from a 400-error response, re-throwing all
-- other exception types.
catchErrorResponse
:: (MonadThrow m, FromJSON a)
=> Either Req.HttpException (JsonResponse a)
-> m (Either BinanceError a)
catchErrorResponse = \case
Right r -> return . Right $ responseBody r
Left e@(VanillaHttpException (HttpExceptionRequest _ (StatusCodeException (statusCode . responseStatus -> 400) errBody)))
-> either (const $ throw e) (return . Left)
$ eitherDecodeStrict' errBody
Left e -> throw e
-- EXCHANGE INFO
-- | Get Exchange Information for the Given Symbol. Right now, just returns
-- the requested symbol information.
--
-- Returns Left if a passed symbol is invalid.
getExchangeInfo
:: (MonadHttp m, MonadCatch m)
=> [T.Text]
-> m (Either BinanceError ExchangeInfo)
getExchangeInfo symbols = do
let symbolsParam =
mconcat
[ "["
, T.intercalate "," (map (\s -> "\"" <> s <> "\"") symbols)
, "]"
]
catchErrorResponse <=< try $ req
GET
(https "api.binance.us" /: "api" /: "v3" /: "exchangeInfo")
NoReqBody
jsonResponse
("symbols" =: symbolsParam)
-- | General information about the exchange. Currently we only parse out
-- the details of requested symbols.
newtype ExchangeInfo = ExchangeInfo
{ eiSymbols :: [SymbolDetails]
} deriving (Show, Read, Eq, Ord)
instance FromJSON ExchangeInfo where
parseJSON =
withObject "ExchangeInfo" $ \o -> ExchangeInfo <$> o .: "symbols"
-- | The asset pairs for a trade symbol, along with Binance's precisions
-- for each asset.
data SymbolDetails = SymbolDetails
{ sdSymbol :: T.Text
, sdBaseAsset :: T.Text
, sdBaseAssetPrecision :: Int
, sdQuoteAsset :: T.Text
, sdQuoteAssetPrecision :: Int
}
deriving (Show, Read, Eq, Ord)
instance FromJSON SymbolDetails where
parseJSON = withObject "SymbolDetails" $ \o -> do
sdSymbol <- o .: "symbol"
sdBaseAsset <- o .: "baseAsset"
sdBaseAssetPrecision <- o .: "baseAssetPrecision"
sdQuoteAsset <- o .: "quoteAsset"
sdQuoteAssetPrecision <- o .: "quoteAssetPrecision"
return SymbolDetails { .. }
-- TRADE HISTORY
-- | Get Trade History for the Given Symbol.
getTradeHistory
:: (MonadHttp m, MonadReader BinanceConfig m)
=> T.Text
-- ^ Full symbol/pair of trades to fetch, e.g. @BNBUSD@.
-> Maybe UTCTime
-- ^ Start of time range
-> Maybe UTCTime
-- ^ End of time range
-> m [Trade]
getTradeHistory symbol mbStart mbEnd = do
cfg <- ask
timestamp <- utcToMs <$> liftIO getCurrentTime
let limit = (1000 :: Int)
resp <- runSignedRequest
GET
(https "api.binance.us" /: "api" /: "v3" /: "myTrades")
NoReqBody
jsonResponse
(mconcat
[ "symbol" =: symbol
, "timestamp" =: timestamp
, "limit" =: limit
, maybe mempty (("startTime" =:) . utcToMs) mbStart
, maybe mempty (("endTime" =:) . utcToMs) mbEnd
, header "X-MBX-APIKEY" (encodeUtf8 $ bcApiKey cfg)
]
)
let results = responseBody resp
if length results /= limit
then return results
else do
let minTime = minimumBy (compare `on` tTime) results
(results <>) <$> getTradeHistory
symbol
mbStart
(Just . posixSecondsToUTCTime $ tTime minTime)
-- | A single trade made on Binance.
data Trade = Trade
{ tSymbol :: T.Text
-- ^ Full symbol of the trade - base asset & quote asset
, tId :: Integer
-- ^ Trade's ID number
, tOrderId :: Integer
-- ^ Order ID number from which the Trade was made
, tPrice :: Scientific
, tQuantity :: Scientific
, tQuoteQuantity :: Scientific
-- ^ The total amount spent/received during the trade. Note that we do
-- not use this value in our exports, as Binance truncates it & loses
-- a fraction of the amount. You probably want to do @'tQuantity'
-- * 'tPrice'@ instead.
, tCommission :: Scientific
, tCommissionAsset :: T.Text
, tTime :: POSIXTime
, tIsBuyer :: Bool
, tIsMaker :: Bool
, tIsBestMatch :: Bool
}
deriving (Show, Read, Eq, Ord)
instance FromJSON Trade where
parseJSON = withObject "Trade" $ \o -> do
tSymbol <- o .: "symbol"
tId <- o .: "id"
tOrderId <- o .: "orderId"
tPrice <- read <$> o .: "price"
tQuantity <- read <$> o .: "qty"
tQuoteQuantity <- read <$> o .: "quoteQty"
tCommission <- read <$> o .: "commission"
tCommissionAsset <- o .: "commissionAsset"
-- Binance API returns milliseconds, POSIXTime is seconds
tTime <- (/ 1000.0) <$> o .: "time"
tIsBuyer <- o .: "isBuyer"
tIsMaker <- o .: "isMaker"
tIsBestMatch <- o .: "isBestMatch"
return Trade { .. }
-- UTILS
-- | Run a request for a SIGNED endpoint by inserting the signature before
-- making the request.
runSignedRequest
:: ( MonadHttp m
, HttpMethod method
, HttpBody body
, HttpResponse response
, HttpBodyAllowed (AllowsBody method) (ProvidesBody body)
, MonadReader BinanceConfig m
)
=> method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
runSignedRequest m u b p s = do
cfg <- ask
reqCb m u b p s $ \req_ -> do
let qs = BS.drop 1 $ queryString req_
body = getBodyBS $ requestBody req_
sig = mkSignature cfg qs body
qs_ = if BS.length qs == 0
then "?signature=" <> sig
else qs <> "&signature=" <> sig
return $ req_ { queryString = qs_ }
where
getBodyBS = \case
RequestBodyLBS lbs -> LBS.toStrict lbs
RequestBodyBS bs -> bs
_ -> ""
-- | Generate a HMAC SHA256 signature for a SIGNED api request.
mkSignature :: BinanceConfig -> BS.ByteString -> BS.ByteString -> BS.ByteString
mkSignature cfg queryParams reqBody =
let totalParams = queryParams <> reqBody
key = encodeUtf8 $ bcApiSecret cfg
in BC.pack . concatMap hexString . BS.unpack $ hmac key totalParams
-- | Convert UTC into posix milliseconds for the Binance API.
utcToMs :: UTCTime -> String
utcToMs = formatTime defaultTimeLocale "%s000"