diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,12 @@ ## master +## v0.1.0.3 + +* Bump `crypton` dependency max version. +* Add an `--ignore-errors` CLI argument, config value, & env var that logs API + errors & continues processing instead of halting execution. + ## v0.1.0.2 * Change crypto library from `cryptonite` to `crypton`. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,4 @@ import Distribution.Simple + + main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,10 @@ module Main where -import Console.Gemini.Exports.Main +import Console.Gemini.Exports.Main main :: IO () main = do args <- getArgs - cfg <- loadConfigFile + cfg <- loadConfigFile run cfg args diff --git a/gemini-exports.cabal b/gemini-exports.cabal --- a/gemini-exports.cabal +++ b/gemini-exports.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: gemini-exports -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Generate CSV Exports of Your Gemini Trades, Transfers, & Earn Transactions description: @gemini-exports@ is a CLI program that queries the Gemini Exchange's API for your Trade History, Transfer History, & Earn History and exports all @@ -28,7 +28,7 @@ bug-reports: https://github.com/prikhi/gemini-exports/issues author: Pavan Rikhi maintainer: pavan.rikhi@gmail.com -copyright: 2022 Pavan Rikhi +copyright: 2026 Pavan Rikhi license: BSD3 license-file: LICENSE build-type: Simple @@ -67,7 +67,7 @@ , cassava <1 , cmdargs >=0.10 && <1 , containers <1 - , crypton <2 + , crypton <3 , directory <2 , http-client <1 , http-types <1 diff --git a/src/Console/Gemini/Exports/Csv.hs b/src/Console/Gemini/Exports/Csv.hs --- a/src/Console/Gemini/Exports/Csv.hs +++ b/src/Console/Gemini/Exports/Csv.hs @@ -1,70 +1,79 @@ {-# LANGUAGE RecordWildCards #-} -{-| Types & functions for converting Gemini API responses into CSV exports. --} + +-- | Types & functions for converting Gemini API responses into CSV exports. module Console.Gemini.Exports.Csv - ( ExportData(..) + ( ExportData (..) , makeExportData , makeExportCsv - , ExportLine(..) + , ExportLine (..) , getExportLineTimestamp ) where -import Control.Applicative ( (<|>) ) -import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Csv ( (.=) - , DefaultOrdered(..) - , ToNamedRecord(..) - , defaultEncodeOptions - , encUseCrLf - , encodeDefaultOrderedByNameWith - , header - , namedRecord - ) -import Data.Maybe ( fromMaybe ) -import Data.Scientific ( FPFormat(Fixed) - , Scientific - , formatScientific - ) -import Data.Text ( Text - , empty - , pack - ) -import Data.Time ( TimeZone - , defaultTimeLocale - , formatTime - , getTimeZone - , utcToZonedTime - ) -import Data.Time.Clock.POSIX ( POSIXTime - , posixSecondsToUTCTime - ) -import Web.Gemini +import Control.Applicative ((<|>)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Csv + ( DefaultOrdered (..) + , ToNamedRecord (..) + , defaultEncodeOptions + , encUseCrLf + , encodeDefaultOrderedByNameWith + , header + , namedRecord + , (.=) + ) +import Data.Maybe (fromMaybe) +import Data.Scientific + ( FPFormat (Fixed) + , Scientific + , formatScientific + ) +import Data.Text + ( Text + , empty + , pack + ) +import Data.Time + ( TimeZone + , defaultTimeLocale + , formatTime + , getTimeZone + , utcToZonedTime + ) +import Data.Time.Clock.POSIX + ( POSIXTime + , posixSecondsToUTCTime + ) -import qualified Data.ByteString.Lazy.Char8 as LBS +import Web.Gemini +import qualified Data.ByteString.Lazy.Char8 as LBS + -- | The data required for rendering a single CSV row. data ExportData = ExportData - { edTZ :: TimeZone + { edTZ :: TimeZone , edLine :: ExportLine } deriving (Show, Read, Eq, Ord) + instance DefaultOrdered ExportData where - headerOrder _ = header - [ "time" - , "base-asset" - , "quote-asset" - , "type" - , "description" - , "price" - , "quantity" - , "total" - , "fee" - , "fee-currency" - , "trade-id" - ] + headerOrder _ = + header + [ "time" + , "base-asset" + , "quote-asset" + , "type" + , "description" + , "price" + , "quantity" + , "total" + , "fee" + , "fee-currency" + , "trade-id" + ] + instance ToNamedRecord ExportData where toNamedRecord (ExportData tz lineData) = namedRecord $ case lineData of TradeExport Trade {..} SymbolDetails {..} -> @@ -112,7 +121,7 @@ toDescr :: (Maybe Text, Maybe Text) -> Text toDescr = \case (Just m, Just p) -> m <> " " <> p - (m , p ) -> fromMaybe "" $ m <|> p + (m, p) -> fromMaybe "" $ m <|> p -- Convert a timestamp into a localtime with the line's timezone -- & render it in `YYYY-MM-DD HH:MM:SS.nnnnnnnnn` format.` formatTimestamp :: POSIXTime -> String @@ -124,18 +133,22 @@ formatDecimal :: Scientific -> Text formatDecimal = pack . formatScientific Fixed Nothing + -- | Determine the 'TimeZone' for the 'ExportLine' & return both as an -- 'ExportData'. -makeExportData :: MonadIO m => ExportLine -> m ExportData +makeExportData :: (MonadIO m) => ExportLine -> m ExportData makeExportData lineData = do - tz <- liftIO . getTimeZone . posixSecondsToUTCTime $ getExportLineTimestamp - lineData + tz <- + liftIO . getTimeZone . posixSecondsToUTCTime $ + getExportLineTimestamp + lineData return $ ExportData tz lineData + -- | Render the export data as a CSV with a header row. makeExportCsv :: [ExportData] -> LBS.ByteString makeExportCsv = - encodeDefaultOrderedByNameWith (defaultEncodeOptions { encUseCrLf = False }) + encodeDefaultOrderedByNameWith (defaultEncodeOptions {encUseCrLf = False}) -- | Split out the data required for different export line types. @@ -145,9 +158,10 @@ | EarnExport EarnTransaction deriving (Show, Read, Eq, Ord) + -- | Get the timestamp field of an 'ExportLine'. getExportLineTimestamp :: ExportLine -> POSIXTime getExportLineTimestamp = \case - TradeExport t _ -> tTimestamp t + TradeExport t _ -> tTimestamp t TransferExport t -> trTimestamp t - EarnExport t -> etTimestamp t + EarnExport t -> etTimestamp t diff --git a/src/Console/Gemini/Exports/Main.hs b/src/Console/Gemini/Exports/Main.hs --- a/src/Console/Gemini/Exports/Main.hs +++ b/src/Console/Gemini/Exports/Main.hs @@ -1,98 +1,124 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{- | CLI application harness. --} +-- | CLI application harness. module Console.Gemini.Exports.Main ( run , getArgs - , Args(..) + , Args (..) , loadConfigFile - , ConfigFile(..) + , ConfigFile (..) ) where -import Control.Applicative ( (<|>) ) -import Control.Exception.Safe ( try ) -import Control.Monad ( forM ) -import Data.Aeson ( (.:?) - , FromJSON(..) - , withObject - ) -import Data.Maybe ( catMaybes - , fromMaybe - ) -import Data.Text ( Text ) -import Data.Time ( LocalTime(..) - , UTCTime(..) - , ZonedTime(..) - , fromGregorian - , getTimeZone - , timeToTimeOfDay - , zonedTimeToUTC - ) -import Data.Version ( showVersion ) -import Data.Yaml ( prettyPrintParseException ) -import Data.Yaml.Config ( ignoreEnv - , loadYamlSettings - ) -import System.Console.CmdArgs ( (&=) - , Data - , Typeable - , cmdArgs - , def - , details - , explicit - , help - , helpArg - , name - , program - , summary - , typ - ) -import System.Directory ( doesFileExist ) -import System.Environment ( lookupEnv ) -import System.Environment.XDG.BaseDir ( getUserConfigFile ) -import System.Exit ( exitFailure ) -import System.IO ( hPutStrLn - , stderr - ) -import Text.RawString.QQ ( r ) +import Control.Applicative ((<|>)) +import Control.Exception.Safe (displayException, try) +import Control.Monad (forM) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson + ( FromJSON (..) + , withObject + , (.:?) + ) +import Data.Maybe + ( catMaybes + , fromMaybe + ) +import Data.Text (Text) +import Data.Time + ( LocalTime (..) + , UTCTime (..) + , ZonedTime (..) + , fromGregorian + , getTimeZone + , timeToTimeOfDay + , zonedTimeToUTC + ) +import Data.Version (showVersion) +import Data.Yaml (prettyPrintParseException) +import Data.Yaml.Config + ( ignoreEnv + , loadYamlSettings + ) +import Network.HTTP.Req (handleHttpException) +import System.Console.CmdArgs + ( Data + , Typeable + , cmdArgs + , def + , details + , explicit + , help + , helpArg + , name + , program + , summary + , typ + , (&=) + ) +import System.Directory (doesFileExist) +import System.Environment (lookupEnv) +import System.Environment.XDG.BaseDir (getUserConfigFile) +import System.Exit (exitFailure) +import System.IO + ( hPutStrLn + , stderr + ) +import Text.RawString.QQ (r) -import Console.Gemini.Exports.Csv -import Paths_gemini_exports ( version ) -import Web.Gemini +import Console.Gemini.Exports.Csv +import Paths_gemini_exports (version) +import Web.Gemini -import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.List as L -import qualified Data.Map.Strict as M -import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.List as L +import qualified Data.Map.Strict as M +import qualified Data.Text as T -- | Run the executable. run :: ConfigFile -> Args -> IO () run cfg cfgArgs = do - AppConfig {..} <- makeConfig cfg cfgArgs - exportData <- runApi geminiCfg $ do - trades <- getMyTrades dateRange + c@AppConfig {..} <- makeConfig cfg cfgArgs + exportData <- runApi geminiCfg $ do + trades <- logOrThrow c [] $ getMyTrades dateRange let symbols = L.nub $ map tSymbol trades - symbolDetails <- fmap M.fromList . forM symbols $ \symbol -> do - (symbol, ) <$> getSymbolDetails symbol + symbolDetails <- fmap (M.fromList . catMaybes) . forM symbols $ \symbol -> do + logOrThrow c Nothing (Just . (symbol,) <$> getSymbolDetails symbol) tradeExport <- fmap catMaybes . forM trades $ \t -> do let mbTrade = TradeExport t <$> M.lookup (tSymbol t) symbolDetails mapM makeExportData mbTrade - transfers <- getMyTransfers dateRange - transferExport <- mapM (makeExportData . TransferExport) transfers - earnTransactions <- getMyEarnTransactions dateRange - earnExport <- mapM (makeExportData . EarnExport) earnTransactions + transfers <- logOrThrow c [] $ getMyTransfers dateRange + transferExport <- mapM (makeExportData . TransferExport) transfers + earnTransactions <- logOrThrow c [] $ getMyEarnTransactions dateRange + earnExport <- mapM (makeExportData . EarnExport) earnTransactions return $ tradeExport <> transferExport <> earnExport let - csvData = makeExportCsv - $ L.sortOn (getExportLineTimestamp . edLine) exportData + csvData = + makeExportCsv $ + L.sortOn (getExportLineTimestamp . edLine) exportData if outputFile == "-" then LBS.putStrLn csvData else LBS.writeFile outputFile csvData + +-- | When some API action results in an error, either log the error +-- & return a default value or call the the 'handleHttpException' method, +-- depending on the 'ignoreErrors' config value. +logOrThrow :: AppConfig -> a -> GeminiApiM a -> GeminiApiM a +logOrThrow c defVal action = + try action >>= \case + Left e -> + if ignoreErrors c + then do + liftIO $ hPutStrLn stderr ("[ERROR] " <> displayException e) + return defVal + else + handleHttpException e + Right result -> + return result + + -- | Print some text to stderr and then exit with an error. exitWithError :: String -> IO a exitWithError msg = hPutStrLn stderr ("[ERROR] " <> msg) >> exitFailure @@ -101,12 +127,14 @@ -- CONFIGURATION data AppConfig = AppConfig - { geminiCfg :: GeminiConfig + { geminiCfg :: GeminiConfig , outputFile :: FilePath - , dateRange :: Maybe (UTCTime, UTCTime) + , dateRange :: Maybe (UTCTime, UTCTime) + , ignoreErrors :: Bool } deriving (Show, Read, Eq, Ord) + -- | Pull Environmental variables, then merge the config file, env vars, -- and cli args into an AppConfig. -- @@ -114,34 +142,42 @@ makeConfig :: ConfigFile -> Args -> IO AppConfig makeConfig ConfigFile {..} Args {..} = do envApiKey <- fmap T.pack <$> lookupEnv "GEMINI_API_KEY" - gcApiKey <- - errorIfNothing "Pass a Gemini API Key with `-k` or $GEMINI_API_KEY." - $ argApiKey - <|> envApiKey - <|> cfgApiKey + gcApiKey <- + errorIfNothing "Pass a Gemini API Key with `-k` or $GEMINI_API_KEY." $ + argApiKey + <|> envApiKey + <|> cfgApiKey envApiSecret <- fmap T.pack <$> lookupEnv "GEMINI_API_SECRET" - gcApiSecret <- + gcApiSecret <- errorIfNothing "Pass a Gemini API Secret with `-s` or $GEMINI_API_SECRET." - $ argApiSecret - <|> envApiSecret - <|> cfgApiSecret - let geminiCfg = GeminiConfig { .. } + $ argApiSecret + <|> envApiSecret + <|> cfgApiSecret + let geminiCfg = GeminiConfig {..} dateRange <- mapM buildDateRange argYear - return AppConfig { outputFile = fromMaybe "-" argOutputFile, .. } + envIgnoreErrors <- fmap (not . null) <$> lookupEnv "GEMINI_API_IGNORE_ERRORS" + let ignoreErrors = + fromMaybe False $ + argIgnoreErrors + <|> envIgnoreErrors + <|> cfgIgnoreErrors + return AppConfig {outputFile = fromMaybe "-" argOutputFile, ..} where - -- | Exit with error message if value is 'Nothing' + -- Exit with error message if value is 'Nothing' errorIfNothing :: String -> Maybe a -> IO a errorIfNothing msg = maybe (exitWithError msg) return - -- | Given a year, build a tuple representing the span of a year in the + -- Given a year, build a tuple representing the span of a year in the -- user's timezone. buildDateRange :: Integer -> IO (UTCTime, UTCTime) buildDateRange y = do let yearStart = UTCTime (fromGregorian y 1 1) 0 - yearEnd = UTCTime (fromGregorian y 12 31) - ((23 * 60 * 60) + (59 * 60) + 59 + 0.9999) + yearEnd = + UTCTime + (fromGregorian y 12 31) + ((23 * 60 * 60) + (59 * 60) + 59 + 0.9999) (,) <$> mkZonedTime yearStart <*> mkZonedTime yearEnd - -- | Shift a time by the user's timezone - coercing it into a ZonedTime + -- Shift a time by the user's timezone - coercing it into a ZonedTime -- and converting that back into UTC. mkZonedTime :: UTCTime -> IO UTCTime mkZonedTime t = do @@ -155,45 +191,51 @@ -- | Optional configuration data parsed from a yaml file. data ConfigFile = ConfigFile - { cfgApiKey :: Maybe Text + { cfgApiKey :: Maybe Text , cfgApiSecret :: Maybe Text + , cfgIgnoreErrors :: Maybe Bool } deriving (Show, Read, Eq, Ord) + instance FromJSON ConfigFile where parseJSON = withObject "ConfigFile" $ \o -> do - cfgApiKey <- o .:? "api-key" + cfgApiKey <- o .:? "api-key" cfgApiSecret <- o .:? "api-secret" - return ConfigFile { .. } + cfgIgnoreErrors <- o .:? "ignore-errors" + return ConfigFile {..} + -- | Attempt to read a 'ConfigFile' from -- @$XDG_CONFIG_HOME\/gemini-exports\/config.yaml@. Print any parsing -- errors to 'stderr'. loadConfigFile :: IO ConfigFile loadConfigFile = do - configPath <- getUserConfigFile "gemini-exports" "config.yaml" + configPath <- getUserConfigFile "gemini-exports" "config.yaml" configExists <- doesFileExist configPath if configExists - then try (loadYamlSettings [configPath] [] ignoreEnv) >>= \case - Left (lines . prettyPrintParseException -> errorMsgs) -> - hPutStrLn stderr "[WARN] Invalid Configuration Format:" - >> mapM_ (hPutStrLn stderr . ("\t" <>)) errorMsgs - >> return defaultConfig - Right cfg -> return cfg + then + try (loadYamlSettings [configPath] [] ignoreEnv) >>= \case + Left (lines . prettyPrintParseException -> errorMsgs) -> + hPutStrLn stderr "[WARN] Invalid Configuration Format:" + >> mapM_ (hPutStrLn stderr . ("\t" <>)) errorMsgs + >> return defaultConfig + Right cfg -> return cfg else return defaultConfig where defaultConfig :: ConfigFile - defaultConfig = ConfigFile Nothing Nothing + defaultConfig = ConfigFile Nothing Nothing Nothing -- CLI ARGS -- | CLI arguments supported by the executable. data Args = Args - { argApiKey :: Maybe Text - , argApiSecret :: Maybe Text + { argApiKey :: Maybe Text + , argApiSecret :: Maybe Text , argOutputFile :: Maybe FilePath - , argYear :: Maybe Integer + , argYear :: Maybe Integer + , argIgnoreErrors :: Maybe Bool } deriving (Show, Read, Eq, Data, Typeable) @@ -207,36 +249,45 @@ argSpec :: Args argSpec = Args - { argApiKey = def - &= name "api-key" - &= name "k" - &= explicit - &= help "Gemini API Key" - &= typ "KEY" - , argApiSecret = def - &= name "api-secret" - &= name "s" - &= explicit - &= help "Gemini API Secret" - &= typ "SECRET" - , argOutputFile = Nothing - &= help "File to write export to. Default: stdout" - &= name "o" - &= name "output-file" - &= explicit - &= typ "FILE" - , argYear = Nothing - &= help "Limit transactions to given year." - &= name "y" - &= name "year" - &= explicit - &= typ "YYYY" - } + { argApiKey = + def + &= name "api-key" + &= name "k" + &= explicit + &= help "Gemini API Key" + &= typ "KEY" + , argApiSecret = + def + &= name "api-secret" + &= name "s" + &= explicit + &= help "Gemini API Secret" + &= typ "SECRET" + , argOutputFile = + Nothing + &= help "File to write export to. Default: stdout" + &= name "o" + &= name "output-file" + &= explicit + &= typ "FILE" + , argYear = + Nothing + &= help "Limit transactions to given year." + &= name "y" + &= name "year" + &= explicit + &= typ "YYYY" + , argIgnoreErrors = + Nothing + &= help "Log, but ignore any API errors." + &= name "ignore-errors" + &= explicit + } &= summary - ( "gemini-exports v" - <> showVersion version - <> ", Pavan Rikhi 2022" - ) + ( "gemini-exports v" + <> showVersion version + <> ", Pavan Rikhi 2025" + ) &= program "gemini-exports" &= helpArg [name "h"] &= help "Generate CSV Exports of your Gemini Trades." @@ -244,7 +295,9 @@ programDetails :: [String] -programDetails = lines [r| +programDetails = + lines + [r| gemini-exports generates a CSV export of your Gemini Trades, Earn Transactions, & Transfers. @@ -281,7 +334,11 @@ you can set the `$GEMINI_API_KEY` & `$GEMINI_API_SECRET` environmental variables. +Setting the `$GEMINI_API_IGNORE_ERRORS` environmental variable to +a non-empty string will log but ignore API errors and attempt to continue +processing. + CONFIGURATION FILE You can also set some program options in a YAML file. We attempt to parse @@ -290,6 +347,7 @@ - `api-key`: (string) Your Gemini API key - `api-secret`: (string) Your Gemini API secret + - `ignore-errors`: (bool) Ignore API errors & process as much as possible Environmental variables will override any configuration options, and CLI flags will override both environmental variables & configuration file diff --git a/src/Web/Gemini.hs b/src/Web/Gemini.hs --- a/src/Web/Gemini.hs +++ b/src/Web/Gemini.hs @@ -1,179 +1,201 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -{-| Request functions & response types for the Gemini Exchange API. --} + +-- | Request functions & response types for the Gemini Exchange API. module Web.Gemini ( GeminiApiM , runApi - , GeminiConfig(..) - , GeminiError(..) - -- * Requests - -- ** Symbol Details + , GeminiConfig (..) + , GeminiError (..) + + -- * Requests + + -- ** Symbol Details , getSymbolDetails - , SymbolDetails(..) - -- ** Trade History + , SymbolDetails (..) + + -- ** Trade History , getMyTrades - , Trade(..) - -- ** Transfer History + , Trade (..) + + -- ** Transfer History , getMyTransfers - , Transfer(..) - -- ** Earn History + , Transfer (..) + + -- ** Earn History , getMyEarnTransactions - , EarnHistory(..) - , EarnTransaction(..) - -- * Helpers + , 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 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 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 +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 + { 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) + } + 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 + { geReason :: Text , geMessage :: Text } deriving (Show, Read, Eq, Ord) + instance FromJSON GeminiError where - parseJSON = withObject "GeminiError" - $ \o -> GeminiError <$> o .: "reason" <*> o .: "message" + 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 :: (MonadHttp m) => Text -> m SymbolDetails getSymbolDetails symbol = responseBody <$> req - GET - ( https "api.gemini.com" + GET + ( https "api.gemini.com" /: "v1" /: "symbols" /: "details" /: symbol - ) - NoReqBody - jsonResponse - userAgentHeader + ) + NoReqBody + jsonResponse + userAgentHeader + -- | Currency & Precision details for a 'Trade' Symbol. data SymbolDetails = SymbolDetails - { sdSymbol :: Text - , sdBaseCurrency :: Text - , sdBasePrecision :: Scientific - , sdQuoteCurrency :: Text + { 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" + sdSymbol <- o .: "symbol" + sdBaseCurrency <- o .: "base_currency" + sdBasePrecision <- o .: "tick_size" + sdQuoteCurrency <- o .: "quote_currency" sdQuotePrecision <- o .: "quote_increment" - return SymbolDetails { .. } + return SymbolDetails {..} -- TRADE HISTORY @@ -188,46 +210,49 @@ 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) - ] + 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 + POST + (https "api.gemini.com" /: "v1" /: "mytrades") + parameters + -- | A single, completed Trade. data Trade = Trade - { tId :: Integer - , tSymbol :: Text - , tPrice :: Scientific - , tAmount :: Scientific + { tId :: Integer + , tSymbol :: Text + , tPrice :: Scientific + , tAmount :: Scientific , tFeeCurrency :: Text - , tFeeAmount :: Scientific - , tIsBuy :: Bool + , tFeeAmount :: Scientific + , tIsBuy :: Bool , tIsAggressor :: Bool - , tTimestamp :: POSIXTime - , tOrderId :: Text + , 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" + 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" + tFeeAmount <- read <$> o .: "fee_amount" + tIsBuy <- (== ("Buy" :: String)) <$> o .: "type" tIsAggressor <- o .: "aggressor" - tTimestamp <- (/ 1000.0) <$> o .: "timestampms" - tOrderId <- o .: "order_id" - return Trade { .. } + tTimestamp <- (/ 1000.0) <$> o .: "timestampms" + tOrderId <- o .: "order_id" + return Trade {..} -- TRANSFER HISTORY @@ -242,42 +267,45 @@ 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) - ] + 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 + 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 + { 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" + 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 { .. } + return Transfer {..} -- EARN HISTORY @@ -290,52 +318,57 @@ 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) - ] + let parameters = + KM.fromList + [ ("request", String "/v1/earn/history") + , ("nonce", toJSON nonce) + , ("since", toJSON timestamp) + , ("sortAsc", toJSON True) + , ("limit", Number 500) + ] concatMap @[] ehTransactions - . responseBody + . responseBody <$> protectedGeminiRequest - POST - (https "api.gemini.com" /: "v1" /: "earn" /: "history") - parameters + POST + (https "api.gemini.com" /: "v1" /: "earn" /: "history") + parameters + -- | Earn Transactions grouped by a Provider/Borrower. data EarnHistory = EarnHistory - { ehProviderId :: Text + { ehProviderId :: Text , ehTransactions :: [EarnTransaction] } + instance FromJSON EarnHistory where - parseJSON = withObject "EarnHistory" - $ \o -> EarnHistory <$> o .: "providerId" <*> o .: "transactions" + parseJSON = withObject "EarnHistory" $ + \o -> EarnHistory <$> o .: "providerId" <*> o .: "transactions" + -- | A single Earn transaction. data EarnTransaction = EarnTransaction - { etId :: Text - , etType :: Text + { etId :: Text + , etType :: Text , etAmountCurrency :: Text - , etAmount :: Scientific - , etPriceCurrency :: Maybe Text - , etPrice :: Maybe Scientific - , etTimestamp :: POSIXTime + , 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" + 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 { .. } + etAmount <- o .: "amount" + etPriceCurrency <- o .:? "priceCurrency" + etPrice <- o .:? "priceAmount" + etTimestamp <- (/ 1000.0) <$> o .: "dateTime" + return EarnTransaction {..} -- UTILS @@ -355,41 +388,46 @@ -> m (JsonResponse response) protectedGeminiRequest method url body = do cfg <- ask - let payload = extractBase64 . encodeBase64' . LBS.toStrict $ encode body + 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 - ] + 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 +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. @@ -412,13 +450,13 @@ then return prevResults else let - maxTimestamp = maximum $ map getTimestamp newResults + maxTimestamp = maximum $ map getTimestamp newResults nextTimestamp = truncate $ 1000 * maxTimestamp + 1 continueFetching = fetchAll (newResults <> prevResults) nextTimestamp filteredResults end = filter ((<= end) . getTimestamp) newResults - in + in case mbRange of Nothing -> continueFetching Just (_, utcTimeToPOSIXSeconds -> end) -> @@ -426,11 +464,13 @@ 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 @@ -442,12 +482,12 @@ createSignature cfg body = let digest = hmacGetDigest @SHA384 $ hmac (encodeUtf8 $ gcApiSecret cfg) body - in BC.pack $ show digest + in BC.pack $ show digest -- | Generate a nonce for authorized requests from the current timestamp in -- milliseconds. -makeNonce :: MonadIO m => m Integer +makeNonce :: (MonadIO m) => m Integer makeNonce = truncate . (1000 *) <$> liftIO getPOSIXTime diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,10 +1,10 @@ -import Hedgehog -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Hedgehog +import Hedgehog +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range main :: IO () @@ -23,9 +23,10 @@ properties :: TestTree -properties = testGroup - "Properties" - [testPropertyNamed "Addition is Communative" "testAdditionCommunative" testAdditionCommunative] +properties = + testGroup + "Properties" + [testPropertyNamed "Addition is Communative" "testAdditionCommunative" testAdditionCommunative] where testAdditionCommunative :: Property testAdditionCommunative = property $ do