diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# CHANGELOG + +## v0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Pavan Rikhi (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Pavan Rikhi nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,56 @@ +# gemini-exports + +[![gemini-exports Build Status](https://github.com/prikhi/gemini-exports/actions/workflows/main.yml/badge.svg)](https://github.com/prikhi/gemini-exports/actions/workflows/main.yml) + + +Generate CSV Exports of your Gemini Trades. + +Requires [`stack`][get-stack]: + +```sh +$ stack run -- -k -s +time,base-asset,quote-asset,type,description,price,quantity,total,fee,fee-currency,trade-id +2022-04-20 04:20:00,GUSD,USD,Buy,,1.0,9001.0,9001.0,0.0,USD,900142424242 +$ stack run -- --help +``` + +[get-stack]: https://docs.haskellstack.org/en/stable/README/ + + +## Install + +You can install the CLI exe by running `stack install`. This lets you call the +executable directly instead of through stack: + +```sh +stack install +export PATH="${HOME}/.local/bin/:${PATH}" +gemini-exports +``` + + +## Build + +You can build the project with stack: + +```sh +stack build +``` + +For development, you can enable fast builds with file-watching, +documentation-building, & test-running: + +```sh +stack test --haddock --fast --file-watch --pedantic +``` + +To build & open the documentation, run: + +```sh +stack haddock --open gemini-exports +``` + + +## LICENSE + +BSD-3 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Console.Gemini.Exports.Main + + +main :: IO () +main = do + args <- getArgs + cfg <- loadConfigFile + run cfg args diff --git a/gemini-exports.cabal b/gemini-exports.cabal new file mode 100644 --- /dev/null +++ b/gemini-exports.cabal @@ -0,0 +1,130 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: gemini-exports +version: 0.1.0.0 +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 + fetched data to a CSV file. + . + You can install @gemini-exports@ with Stack: @stack install --resolver + nightly gemii-exports@. Then run the following to print out your complete + history: + . + @ + $ gemini-exports -k \ -s \ + time,base-asset,quote-asset,type,description,price,quantity,total,fee,fee-currency,trade-id + 2022-04-20 04:20:00,GUSD,USD,Buy,,1.0,9001.0,9001.0,0.0,USD,900142424242 + @ + . + See @gemini-exports --help@ for additional options, configuration file + details, etc. +category: Web, Finance, Console +homepage: https://github.com/prikhi/gemini-exports#readme +bug-reports: https://github.com/prikhi/gemini-exports/issues +author: Pavan Rikhi +maintainer: pavan.rikhi@gmail.com +copyright: 2022 Pavan Rikhi +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/prikhi/gemini-exports + +library + exposed-modules: + Console.Gemini.Exports.Csv + Console.Gemini.Exports.Main + Web.Gemini + other-modules: + Paths_gemini_exports + hs-source-dirs: + src + default-extensions: + DeriveGeneric + LambdaCase + NamedFieldPuns + OverloadedStrings + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -O2 -Wunused-packages + build-depends: + aeson <3 + , base >=4.7 && <5 + , base64 <1 + , bytestring <1 + , cassava <1 + , cmdargs >=0.10 && <1 + , containers <1 + , cryptonite <1 + , directory <2 + , http-client <1 + , http-types <1 + , mtl <3 + , raw-strings-qq <2 + , req <4 + , safe-exceptions <1 + , scientific <1 + , text <3 + , time <2 + , xdg-basedir <1 + , yaml <1 + default-language: Haskell2010 + +executable gemini-exports + main-is: Main.hs + other-modules: + Paths_gemini_exports + hs-source-dirs: + app + default-extensions: + DeriveGeneric + LambdaCase + NamedFieldPuns + OverloadedStrings + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -O2 -threaded -rtsopts -with-rtsopts "-N -T" + build-depends: + base >=4.7 && <5 + , gemini-exports + default-language: Haskell2010 + +test-suite gemini-exports-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_gemini_exports + hs-source-dirs: + tests + default-extensions: + DeriveGeneric + LambdaCase + NamedFieldPuns + OverloadedStrings + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -O2 -threaded -rtsopts -with-rtsopts "-N -T" + build-depends: + base >=4.7 && <5 + , gemini-exports + , hedgehog + , tasty + , tasty-hedgehog >=1.2 + , tasty-hunit + default-language: Haskell2010 diff --git a/src/Console/Gemini/Exports/Csv.hs b/src/Console/Gemini/Exports/Csv.hs new file mode 100644 --- /dev/null +++ b/src/Console/Gemini/Exports/Csv.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE RecordWildCards #-} +{-| Types & functions for converting Gemini API responses into CSV exports. +-} +module Console.Gemini.Exports.Csv + ( ExportData(..) + , makeExportData + , makeExportCsv + , 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 qualified Data.ByteString.Lazy.Char8 as LBS + + +-- | The data required for rendering a single CSV row. +data ExportData = ExportData + { 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" + ] + +instance ToNamedRecord ExportData where + toNamedRecord (ExportData tz lineData) = namedRecord $ case lineData of + TradeExport Trade {..} SymbolDetails {..} -> + [ "time" .= formatTimestamp tTimestamp + , "base-asset" .= sdBaseCurrency + , "quote-asset" .= sdQuoteCurrency + , "type" .= if tIsBuy then "Buy" else ("Sell" :: Text) + , "description" .= empty + , "price" .= formatDecimal tPrice + , "quantity" .= formatDecimal tAmount + , "total" .= formatDecimal (tPrice * tAmount) + , "fee" .= formatDecimal tFeeAmount + , "fee-currency" .= tFeeCurrency + , "trade-id" .= tId + ] + TransferExport Transfer {..} -> + [ "time" .= formatTimestamp trTimestamp + , "base-asset" .= trCurrency + , "quote-asset" .= empty + , "type" .= trType + , "description" .= toDescr (trMethod, trPurpose) + , "price" .= empty + , "quantity" .= formatDecimal trAmount + , "total" .= formatDecimal trAmount + , "fee" .= empty + , "fee-currency" .= empty + , "trade-id" .= trId + ] + EarnExport EarnTransaction {..} -> + [ "time" .= formatTimestamp etTimestamp + , "base-asset" .= etAmountCurrency + , "quote-asset" .= fromMaybe empty etPriceCurrency + , "type" .= ("Earn " <> etType) + , "description" .= empty + , "price" .= maybe empty formatDecimal etPrice + , "quantity" .= formatDecimal etAmount + , "total" .= maybe empty (formatDecimal . (* etAmount)) etPrice + , "fee" .= empty + , "fee-currency" .= empty + , "trade-id" .= etId + ] + where + -- Render a transfer description by combining the optional method + -- & purpose fields. + toDescr :: (Maybe Text, Maybe Text) -> Text + toDescr = \case + (Just m, Just p) -> 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 + formatTimestamp = + formatTime defaultTimeLocale "%F %T%Q" + . utcToZonedTime tz + . posixSecondsToUTCTime + -- Render a decimal number with the minimum precision neccesary.. + 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 lineData = do + 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 }) + + +-- | Split out the data required for different export line types. +data ExportLine + = TradeExport Trade SymbolDetails + | TransferExport Transfer + | EarnExport EarnTransaction + deriving (Show, Read, Eq, Ord) + +-- | Get the timestamp field of an 'ExportLine'. +getExportLineTimestamp :: ExportLine -> POSIXTime +getExportLineTimestamp = \case + TradeExport t _ -> tTimestamp t + TransferExport t -> trTimestamp t + EarnExport t -> etTimestamp t diff --git a/src/Console/Gemini/Exports/Main.hs b/src/Console/Gemini/Exports/Main.hs new file mode 100644 --- /dev/null +++ b/src/Console/Gemini/Exports/Main.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{- | CLI application harness. + +-} +module Console.Gemini.Exports.Main + ( run + , getArgs + , Args(..) + , loadConfigFile + , 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 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 + + +-- | Run the executable. +run :: ConfigFile -> Args -> IO () +run cfg cfgArgs = do + AppConfig {..} <- makeConfig cfg cfgArgs + exportData <- runApi geminiCfg $ do + trades <- getMyTrades dateRange + let symbols = L.nub $ map tSymbol trades + symbolDetails <- fmap M.fromList . forM symbols $ \symbol -> do + (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 + return $ tradeExport <> transferExport <> earnExport + let + csvData = makeExportCsv + $ L.sortOn (getExportLineTimestamp . edLine) exportData + if outputFile == "-" + then LBS.putStrLn csvData + else LBS.writeFile outputFile csvData + +-- | Print some text to stderr and then exit with an error. +exitWithError :: String -> IO a +exitWithError msg = hPutStrLn stderr ("[ERROR] " <> msg) >> exitFailure + + +-- CONFIGURATION + +data AppConfig = AppConfig + { geminiCfg :: GeminiConfig + , outputFile :: FilePath + , dateRange :: Maybe (UTCTime, UTCTime) + } + deriving (Show, Read, Eq, Ord) + +-- | Pull Environmental variables, then merge the config file, env vars, +-- and cli args into an AppConfig. +-- +-- Exit with an error if we cannot construct a 'GeminiConfig'. +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 + envApiSecret <- fmap T.pack <$> lookupEnv "GEMINI_API_SECRET" + gcApiSecret <- + errorIfNothing + "Pass a Gemini API Secret with `-s` or $GEMINI_API_SECRET." + $ argApiSecret + <|> envApiSecret + <|> cfgApiSecret + let geminiCfg = GeminiConfig { .. } + dateRange <- mapM buildDateRange argYear + return AppConfig { outputFile = fromMaybe "-" argOutputFile, .. } + where + -- | 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 + -- 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) + (,) <$> mkZonedTime yearStart <*> mkZonedTime yearEnd + -- | 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 + tz <- getTimeZone t + let localTime = LocalTime (utctDay t) (timeToTimeOfDay $ utctDayTime t) + zonedTime = ZonedTime localTime tz + return $ zonedTimeToUTC zonedTime + + +-- CONFIG FILE + +-- | Optional configuration data parsed from a yaml file. +data ConfigFile = ConfigFile + { cfgApiKey :: Maybe Text + , cfgApiSecret :: Maybe Text + } + deriving (Show, Read, Eq, Ord) + +instance FromJSON ConfigFile where + parseJSON = withObject "ConfigFile" $ \o -> do + cfgApiKey <- o .:? "api-key" + cfgApiSecret <- o .:? "api-secret" + 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" + 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 + else return defaultConfig + where + defaultConfig :: ConfigFile + defaultConfig = ConfigFile Nothing Nothing + + +-- CLI ARGS + +-- | CLI arguments supported by the executable. +data Args = Args + { argApiKey :: Maybe Text + , argApiSecret :: Maybe Text + , argOutputFile :: Maybe FilePath + , argYear :: Maybe Integer + } + deriving (Show, Read, Eq, Data, Typeable) + + +-- | Parse the CLI arguments with 'System.Console.CmdArgs'. +getArgs :: IO Args +getArgs = cmdArgs argSpec + + +-- | Defines & documents the CLI arguments. +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" + } + &= summary + ( "gemini-exports v" + <> showVersion version + <> ", Pavan Rikhi 2022" + ) + &= program "gemini-exports" + &= helpArg [name "h"] + &= help "Generate CSV Exports of your Gemini Trades." + &= details programDetails + + +programDetails :: [String] +programDetails = lines [r| +gemini-exports generates a CSV export of your Gemini Trades, Earn +Transactions, & Transfers. + + +DESCRIPTION + +By default, we will pull every single trade, transfer, and income you have +made on Gemini & print them out in chronological order with the following +fields: + + time,base-asset,quote-asset,type,description,price,quantity,total,fee,fee-currency,trade-id + +Trades have blank descriptions. + +Transfers have blank quote-assets, prices, & fees and potential blank +descriptions. + +Earn transactions have blank descriptions & fees and potentially blank +quote-assets, price, & totals. + + +OUTPUT FILE + +You can use the `-o` flag to set the file we will write the CSV data into. +By default, the export is simply printed to stdout. + +Warning: the export file will always be overwritten. We do not support +appending to an existing file. + + +ENVIRONMENTAL VARIABLES + +Instead of passing in your API credentials via the `-k` & `-s` CLI flags, +you can set the `$GEMINI_API_KEY` & `$GEMINI_API_SECRET` environmental +variables. + + +CONFIGURATION FILE + +You can also set some program options in a YAML file. We attempt to parse +a configuration file at `$XDG_CONFIG_HOME/gemini-exports/config.yaml`. It +supports the following top-level keys: + + - `api-key`: (string) Your Gemini API key + - `api-secret`: (string) Your Gemini API secret + +Environmental variables will override any configuration options, and CLI +flags will override both environmental variables & configuration file +options. + + +USAGE EXAMPLES + +Fetch all my trades, deposits, withdrawals, & earn transactions: + gemini-exports -k -s + +Fetch my Gemini history from 2020: + gemini-exports -y 2020 + +Fetch my history from 2022, write them to a file: + gemini-exports -y 2022 -o 2022-gemini-history.csv +|] diff --git a/src/Web/Gemini.hs b/src/Web/Gemini.hs new file mode 100644 --- /dev/null +++ b/src/Web/Gemini.hs @@ -0,0 +1,456 @@ +{-# 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.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 = encodeUtf8 . 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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,34 @@ +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 + + +main :: IO () +main = defaultMain tests + + +tests :: TestTree +tests = testGroup "Tests" [unitTests, properties] + + +unitTests :: TestTree +unitTests = testGroup "Unit Tests" [testCase "2+2 = 4" testAddition] + where + testAddition :: Assertion + testAddition = (2 + 2) @?= (4 :: Integer) + + +properties :: TestTree +properties = testGroup + "Properties" + [testPropertyNamed "Addition is Communative" "testAdditionCommunative" testAdditionCommunative] + where + testAdditionCommunative :: Property + testAdditionCommunative = property $ do + let genInt = Gen.int $ Range.linear 0 9001 + (a, b) <- forAll $ (,) <$> genInt <*> genInt + (a + b) === (b + a)