{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
-- | Request functions & response types for the Gemini Exchange API.
module Web.Gemini
( GeminiApiM
, runApi
, GeminiConfig (..)
, GeminiError (..)
-- * Requests
-- ** Symbol Details
, getSymbolDetails
, SymbolDetails (..)
-- ** Trade History
, getMyTrades
, Trade (..)
-- ** Transfer History
, getMyTransfers
, Transfer (..)
-- ** Earn History
, getMyEarnTransactions
, EarnHistory (..)
, EarnTransaction (..)
-- * Helpers
, protectedGeminiRequest
, retryWithRateLimit
, createSignature
, makeNonce
) where
import Control.Concurrent (threadDelay)
import Control.Exception.Safe
( MonadCatch
, MonadThrow
, try
)
import Control.Monad.Reader
( MonadIO (liftIO)
, MonadReader (ask)
, ReaderT (..)
, lift
)
import Crypto.Hash (SHA384)
import Crypto.MAC.HMAC
( hmac
, hmacGetDigest
)
import Data.Aeson
( FromJSON (..)
, ToJSON (..)
, Value (..)
, eitherDecode
, encode
, withObject
, (.:)
, (.:?)
)
import Data.Base64.Types (extractBase64)
import Data.ByteString.Base64 (encodeBase64')
import Data.Maybe
( fromMaybe
, listToMaybe
, mapMaybe
)
import Data.Ratio ((%))
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX
( POSIXTime
, getPOSIXTime
, utcTimeToPOSIXSeconds
)
import Data.Version (showVersion)
import GHC.Generics (Generic)
import Network.HTTP.Client
( HttpException (..)
, HttpExceptionContent (..)
, responseStatus
)
import Network.HTTP.Req
( GET (..)
, HttpBodyAllowed
, HttpException (..)
, HttpMethod (..)
, JsonResponse
, MonadHttp (..)
, NoReqBody (..)
, Option
, POST (..)
, ProvidesBody
, Req
, Url
, defaultHttpConfig
, header
, https
, jsonResponse
, req
, responseBody
, runReq
, (/:)
)
import Network.HTTP.Types (Status (..))
import Text.Read (readMaybe)
import Paths_gemini_exports (version)
import qualified Data.Aeson.KeyMap as KM
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
-- | Required configuration data for making requests to the Gemini API.
data GeminiConfig = GeminiConfig
{ gcApiKey :: Text
, gcApiSecret :: Text
}
deriving (Show, Read, Eq, Ord)
-- | Monad in which Gemini API requests are run.
newtype GeminiApiM a = GeminiApiM
{ runGeminiApiM :: ReaderT GeminiConfig Req a
}
deriving (Functor, Applicative, Monad, MonadIO, MonadReader GeminiConfig, MonadThrow, MonadCatch)
-- | Run a series of API requests with the given Config.
runApi :: GeminiConfig -> GeminiApiM a -> IO a
runApi cfg = runReq defaultHttpConfig . flip runReaderT cfg . runGeminiApiM
-- | Use 'MonadHttp' from the 'Req' monad.
instance MonadHttp GeminiApiM where
handleHttpException = GeminiApiM . lift . handleHttpException
-- | Potential error response body from the API.
data GeminiError = GeminiError
{ geReason :: Text
, geMessage :: Text
}
deriving (Show, Read, Eq, Ord)
instance FromJSON GeminiError where
parseJSON = withObject "GeminiError" $
\o -> GeminiError <$> o .: "reason" <*> o .: "message"
-- SYMBOL DETAILS
-- | Fetch the details on a supported symbol.
getSymbolDetails :: (MonadHttp m) => Text -> m SymbolDetails
getSymbolDetails symbol =
responseBody
<$> req
GET
( https "api.gemini.com"
/: "v1"
/: "symbols"
/: "details"
/: symbol
)
NoReqBody
jsonResponse
userAgentHeader
-- | Currency & Precision details for a 'Trade' Symbol.
data SymbolDetails = SymbolDetails
{ sdSymbol :: Text
, sdBaseCurrency :: Text
, sdBasePrecision :: Scientific
, sdQuoteCurrency :: Text
, sdQuotePrecision :: Scientific
}
deriving (Show, Read, Eq, Ord, Generic)
instance FromJSON SymbolDetails where
parseJSON = withObject "SymbolDetails" $ \o -> do
sdSymbol <- o .: "symbol"
sdBaseCurrency <- o .: "base_currency"
sdBasePrecision <- o .: "tick_size"
sdQuoteCurrency <- o .: "quote_currency"
sdQuotePrecision <- o .: "quote_increment"
return SymbolDetails {..}
-- TRADE HISTORY
-- | Fetch all my Gemini Trades
getMyTrades
:: Maybe (UTCTime, UTCTime)
-- ^ Optional @(start, end)@ ranges for fetching.
-> GeminiApiM [Trade]
getMyTrades = fetchAllPages getTradeBatch tTimestamp
where
getTradeBatch :: Integer -> GeminiApiM [Trade]
getTradeBatch timestamp = do
nonce <- makeNonce
let parameters =
KM.fromList
[ ("request", String "/v1/mytrades")
, ("nonce", toJSON nonce)
, ("timestamp", toJSON $ timestampToSeconds timestamp)
, ("limit_trades", Number 500)
]
responseBody
<$> protectedGeminiRequest
POST
(https "api.gemini.com" /: "v1" /: "mytrades")
parameters
-- | A single, completed Trade.
data Trade = Trade
{ tId :: Integer
, tSymbol :: Text
, tPrice :: Scientific
, tAmount :: Scientific
, tFeeCurrency :: Text
, tFeeAmount :: Scientific
, tIsBuy :: Bool
, tIsAggressor :: Bool
, tTimestamp :: POSIXTime
, tOrderId :: Text
}
deriving (Show, Read, Eq, Ord, Generic)
instance FromJSON Trade where
parseJSON = withObject "Trade" $ \o -> do
tId <- o .: "tid"
tSymbol <- o .: "symbol"
tPrice <- read <$> o .: "price"
tAmount <- read <$> o .: "amount"
tFeeCurrency <- o .: "fee_currency"
tFeeAmount <- read <$> o .: "fee_amount"
tIsBuy <- (== ("Buy" :: String)) <$> o .: "type"
tIsAggressor <- o .: "aggressor"
tTimestamp <- (/ 1000.0) <$> o .: "timestampms"
tOrderId <- o .: "order_id"
return Trade {..}
-- TRANSFER HISTORY
-- | Fetch all my Gemini Transfers
getMyTransfers
:: Maybe (UTCTime, UTCTime)
-- ^ Optional @(start, end)@ ranges for fetching.
-> GeminiApiM [Transfer]
getMyTransfers = fetchAllPages getTransferBatch trTimestamp
where
getTransferBatch :: Integer -> GeminiApiM [Transfer]
getTransferBatch timestamp = do
nonce <- makeNonce
let parameters =
KM.fromList
[ ("request", String "/v1/transfers")
, ("nonce", toJSON nonce)
, ("timestamp", toJSON $ timestampToSeconds timestamp)
, ("limit_transfers", Number 50)
]
responseBody
<$> protectedGeminiRequest
POST
(https "api.gemini.com" /: "v1" /: "transfers")
parameters
-- | A single fiat or cryptocurrency transfer, credit, deposit, or withdrawal.
data Transfer = Transfer
{ trId :: Integer
, trType :: Text
, trStatus :: Text
, trCurrency :: Text
, trAmount :: Scientific
, trMethod :: Maybe Text
, trPurpose :: Maybe Text
, trTimestamp :: POSIXTime
}
deriving (Show, Read, Eq, Ord, Generic)
instance FromJSON Transfer where
parseJSON = withObject "Transfer" $ \o -> do
trId <- o .: "eid"
trType <- o .: "type"
trStatus <- o .: "status"
trCurrency <- o .: "currency"
trAmount <- read <$> o .: "amount"
trMethod <- o .:? "method"
trPurpose <- o .:? "purpose"
trTimestamp <- (/ 1000) <$> o .: "timestampms"
return Transfer {..}
-- EARN HISTORY
-- | Fetch all my Gemini Earn Transactions
getMyEarnTransactions
:: Maybe (UTCTime, UTCTime) -> GeminiApiM [EarnTransaction]
getMyEarnTransactions = fetchAllPages getEarnBatch etTimestamp
where
getEarnBatch :: Integer -> GeminiApiM [EarnTransaction]
getEarnBatch timestamp = do
nonce <- makeNonce
let parameters =
KM.fromList
[ ("request", String "/v1/earn/history")
, ("nonce", toJSON nonce)
, ("since", toJSON timestamp)
, ("sortAsc", toJSON True)
, ("limit", Number 500)
]
concatMap @[] ehTransactions
. responseBody
<$> protectedGeminiRequest
POST
(https "api.gemini.com" /: "v1" /: "earn" /: "history")
parameters
-- | Earn Transactions grouped by a Provider/Borrower.
data EarnHistory = EarnHistory
{ ehProviderId :: Text
, ehTransactions :: [EarnTransaction]
}
instance FromJSON EarnHistory where
parseJSON = withObject "EarnHistory" $
\o -> EarnHistory <$> o .: "providerId" <*> o .: "transactions"
-- | A single Earn transaction.
data EarnTransaction = EarnTransaction
{ etId :: Text
, etType :: Text
, etAmountCurrency :: Text
, etAmount :: Scientific
, etPriceCurrency :: Maybe Text
, etPrice :: Maybe Scientific
, etTimestamp :: POSIXTime
}
deriving (Show, Read, Eq, Ord, Generic)
instance FromJSON EarnTransaction where
parseJSON = withObject "EarnTransaction" $ \o -> do
etId <- o .: "earnTransactionId"
etType <- o .: "transactionType"
etAmountCurrency <- o .: "amountCurrency"
etAmount <- o .: "amount"
etPriceCurrency <- o .:? "priceCurrency"
etPrice <- o .:? "priceAmount"
etTimestamp <- (/ 1000.0) <$> o .: "dateTime"
return EarnTransaction {..}
-- UTILS
-- | Run a request that requires authorization against the Gemini API.
protectedGeminiRequest
:: ( MonadHttp m
, HttpMethod method
, HttpBodyAllowed (AllowsBody method) (ProvidesBody NoReqBody)
, ToJSON body
, FromJSON response
, MonadReader GeminiConfig m
)
=> method
-> Url scheme
-> body
-> m (JsonResponse response)
protectedGeminiRequest method url body = do
cfg <- ask
let payload = extractBase64 . encodeBase64' . LBS.toStrict $ encode body
signature = createSignature cfg payload
let authorizedOptions =
mconcat
[ header "Content-Type" "text/plain"
, header "X-GEMINI-APIKEY" (encodeUtf8 $ gcApiKey cfg)
, header "X-GEMINI-PAYLOAD" payload
, header "X-GEMINI-SIGNATURE" signature
, header "Cache-Control" "no-cache"
, userAgentHeader
]
req method url NoReqBody jsonResponse authorizedOptions
-- | Attempt a request & retry if a @429@ @RateLimited@ error is returned.
-- We attempt to parse the retry wait time from the @message@ field but
-- fallback to one second.
retryWithRateLimit :: (MonadHttp m, MonadCatch m) => m a -> m a
retryWithRateLimit request =
try request >>= \case
Left e@(VanillaHttpException (HttpExceptionRequest _ (StatusCodeException (statusCode . responseStatus -> 429) body))) ->
case eitherDecode $ LBS.fromStrict body of
Left _ -> handleHttpException e
Right r ->
if geReason r == "RateLimited"
then
let msToWait =
fromMaybe 1000
. listToMaybe
. mapMaybe (readMaybe . T.unpack)
. T.words
$ geMessage r
in do
liftIO . threadDelay $ msToWait * 1000
retryWithRateLimit request
else handleHttpException e
Left e -> handleHttpException e
Right r -> return r
-- | Fetch all pages of a response by calling the API with increasing
-- timestamp fields until it returns an empty response. Takes an optional
-- start & end date to offset the initial fetch & stop fetching early.
fetchAllPages
:: (Integer -> GeminiApiM [a])
-- ^ Make a request for items above the given milliseconds @timestamp@
-> (a -> POSIXTime)
-- ^ Pull a timestamp from an item
-> Maybe (UTCTime, UTCTime)
-- ^ Optional @(start, end)@ range
-> GeminiApiM [a]
fetchAllPages mkRequest getTimestamp mbRange = do
let startTimestamp =
maybe 0 (truncate . (1000 *) . utcTimeToPOSIXSeconds . fst) mbRange
fetchAll [] startTimestamp
where
fetchAll prevResults timestamp = do
newResults <- retryWithRateLimit $ mkRequest timestamp
if null newResults
then return prevResults
else
let
maxTimestamp = maximum $ map getTimestamp newResults
nextTimestamp = truncate $ 1000 * maxTimestamp + 1
continueFetching =
fetchAll (newResults <> prevResults) nextTimestamp
filteredResults end =
filter ((<= end) . getTimestamp) newResults
in
case mbRange of
Nothing -> continueFetching
Just (_, utcTimeToPOSIXSeconds -> end) ->
if maxTimestamp >= end
then return $ filteredResults end <> prevResults
else continueFetching
-- | Given a timestamp in ms, convert it to a timestamp param in seconds by
-- dividing & rounding up.
timestampToSeconds :: Integer -> Integer
timestampToSeconds = ceiling . (% 1000)
-- | Generate a 'Crypto.MAC.HMAC.HMAC' 'SHA384' signature for an authorized
-- API request.
createSignature
:: GeminiConfig
-- ^ API Credentials
-> BS.ByteString
-- ^ Base64-encoded request body.
-> BS.ByteString
createSignature cfg body =
let digest =
hmacGetDigest @SHA384 $ hmac (encodeUtf8 $ gcApiSecret cfg) body
in BC.pack $ show digest
-- | Generate a nonce for authorized requests from the current timestamp in
-- milliseconds.
makeNonce :: (MonadIO m) => m Integer
makeNonce = truncate . (1000 *) <$> liftIO getPOSIXTime
-- | Generate a @User-Agent@ header with the library's current version.
userAgentHeader :: Option scheme
userAgentHeader =
header "User-Agent" . BC.pack $ "gemini-exports/v" <> showVersion version