gemini-exports 0.1.0.2 → 0.1.0.3
raw patch · 8 files changed
+539/−418 lines, 8 filessetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Console.Gemini.Exports.Main: [argIgnoreErrors] :: Args -> Maybe Bool
+ Console.Gemini.Exports.Main: [cfgIgnoreErrors] :: ConfigFile -> Maybe Bool
- Console.Gemini.Exports.Main: Args :: Maybe Text -> Maybe Text -> Maybe FilePath -> Maybe Integer -> Args
+ Console.Gemini.Exports.Main: Args :: Maybe Text -> Maybe Text -> Maybe FilePath -> Maybe Integer -> Maybe Bool -> Args
- Console.Gemini.Exports.Main: ConfigFile :: Maybe Text -> Maybe Text -> ConfigFile
+ Console.Gemini.Exports.Main: ConfigFile :: Maybe Text -> Maybe Text -> Maybe Bool -> ConfigFile
- Web.Gemini: protectedGeminiRequest :: (MonadHttp m, HttpMethod method, HttpBodyAllowed (AllowsBody method) (ProvidesBody NoReqBody), ToJSON body, FromJSON response, MonadReader GeminiConfig m) => method -> Url scheme -> body -> m (JsonResponse response)
+ Web.Gemini: protectedGeminiRequest :: forall m method body response (scheme :: Scheme). (MonadHttp m, HttpMethod method, HttpBodyAllowed (AllowsBody method) (ProvidesBody NoReqBody), ToJSON body, FromJSON response, MonadReader GeminiConfig m) => method -> Url scheme -> body -> m (JsonResponse response)
Files
- CHANGELOG.md +6/−0
- Setup.hs +2/−0
- app/Main.hs +2/−2
- gemini-exports.cabal +4/−4
- src/Console/Gemini/Exports/Csv.hs +70/−56
- src/Console/Gemini/Exports/Main.hs +188/−130
- src/Web/Gemini.hs +257/−217
- tests/Spec.hs +10/−9
CHANGELOG.md view
@@ -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`.
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++ main = defaultMain
app/Main.hs view
@@ -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
gemini-exports.cabal view
@@ -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
src/Console/Gemini/Exports/Csv.hs view
@@ -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
src/Console/Gemini/Exports/Main.hs view
@@ -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
src/Web/Gemini.hs view
@@ -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
tests/Spec.hs view
@@ -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