diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,16 @@ ## master + +## v0.1.3.0 + +* Bump dependency versions(text). +* Add `--aggregate` flag to group rewards by day. +* Fetch rewards until no more rewards are returned instead of stopping when + less than the 5-item page limit is returned. +* Handle breaking API changes when rate limited. + + ## v0.1.2.0 * Add `--year` flag to allow filtering the output by date. 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,8 +1,9 @@ module Main where -import Console.SolanaStaking.Main ( getArgs - , run - ) +import Console.SolanaStaking.Main + ( getArgs + , run + ) main :: IO () diff --git a/solana-staking-csvs.cabal b/solana-staking-csvs.cabal --- a/solana-staking-csvs.cabal +++ b/solana-staking-csvs.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: solana-staking-csvs -version: 0.1.2.0 +version: 0.1.3.0 synopsis: Generate CSV Exports of your Solana Staking Rewards. description: @solana-staking-csvs@ is a CLI program that queries the Solana blockchain for an account's staking accounts and exports all their staking rewards to @@ -29,7 +29,7 @@ bug-reports: https://github.com/prikhi/solana-staking-csvs/issues author: Pavan Rikhi maintainer: pavan.rikhi@gmail.com -copyright: 2021 Pavan Rikhi +copyright: 2021-2024 Pavan Rikhi license: BSD3 license-file: LICENSE build-type: Simple @@ -54,6 +54,7 @@ default-extensions: DataKinds DeriveGeneric + ImportQualifiedPost LambdaCase OverloadedStrings TupleSections @@ -67,10 +68,14 @@ , cassava <1 , cmdargs >=0.10 && <1 , cointracking-imports <1 + , containers <1 + , exceptions <1 + , http-client <1 + , http-types <1 , mtl ==2.* , req >=3.4 && <4 , scientific <1 - , text <2 + , text <3 , time <2 default-language: Haskell2010 @@ -83,6 +88,7 @@ default-extensions: DataKinds DeriveGeneric + ImportQualifiedPost LambdaCase OverloadedStrings TupleSections @@ -104,6 +110,7 @@ default-extensions: DataKinds DeriveGeneric + ImportQualifiedPost LambdaCase OverloadedStrings TupleSections diff --git a/src/Console/SolanaStaking/Api.hs b/src/Console/SolanaStaking/Api.hs --- a/src/Console/SolanaStaking/Api.hs +++ b/src/Console/SolanaStaking/Api.hs @@ -1,93 +1,102 @@ -{-| Solana Beach API requests & responses. - -TODO: Extract into a @solana-beach-api@ package. --} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} + +{- | Solana Beach API requests & responses. + +TODO: Extract into a @solana-beach-api@ package. +-} module Console.SolanaStaking.Api ( -- * Configuration - Config(..) + Config (..) , mkConfig + -- * Requests / Responses - , APIResponse(..) - , APIError(..) + , APIResponse (..) + , APIError (..) , runApi , raiseAPIError + -- ** Get Stake Accounts , getAccountStakes - , StakingAccounts(..) - , StakingAccount(..) + , StakingAccounts (..) + , StakingAccount (..) + -- ** Get Staking Rewards , getAllStakeRewards , getYearsStakeRewards , getStakeRewards - , StakeReward(..) + , StakeReward (..) + -- ** Get Block , getBlock - , Block(..) + , Block (..) + -- * General API Types - , Lamports(..) + , Lamports (..) , renderLamports , scientificLamports - , StakingPubKey(..) + , StakingPubKey (..) ) where -import Control.Concurrent ( threadDelay ) -import Control.Monad.Except ( MonadError(throwError) - , runExceptT - ) -import Control.Monad.Reader ( MonadIO - , MonadReader - , asks - , liftIO - ) -import Data.Aeson ( (.:) - , (.:?) - , FromJSON(parseJSON) - , Value(Object) - , withObject - ) -import Data.Bifunctor ( second ) -import Data.Scientific ( FPFormat(Fixed) - , Scientific - , formatScientific - ) -import Data.Text.Encoding ( encodeUtf8 ) -import Data.Time ( toGregorian - , utctDay - ) -import Data.Time.Clock.POSIX ( POSIXTime - , posixSecondsToUTCTime - ) -import GHC.Generics ( Generic ) -import Network.HTTP.Req ( (/:) - , (/~) - , GET(GET) - , NoReqBody(NoReqBody) - , Option - , Scheme(Https) - , Url - , defaultHttpConfig - , header - , https - , jsonResponse - , queryParam - , renderUrl - , req - , responseBody - , runReq - ) -import System.IO ( hPutStrLn - , stderr - ) +import Control.Concurrent (threadDelay) +import Control.Exception (throwIO) +import Control.Monad ((>=>)) +import Control.Monad.Catch (MonadCatch, try) +import Control.Monad.Except (MonadError (throwError), runExceptT) +import Control.Monad.Reader (MonadIO, MonadReader, asks, liftIO) +import Data.Aeson + ( FromJSON (parseJSON) + , Value (Object) + , eitherDecode + , withObject + , (.:) + , (.:?) + ) +import Data.Bifunctor (second) +import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific) +import Data.Text.Encoding (encodeUtf8) +import Data.Time (toGregorian, utctDay) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) +import GHC.Generics (Generic) +import Network.HTTP.Client + ( HttpException (..) + , HttpExceptionContent (..) + , responseStatus + ) +import Network.HTTP.Req + ( GET (GET) + , HttpException (..) + , HttpResponse + , HttpResponseBody + , NoReqBody (NoReqBody) + , Option + , Scheme (Https) + , Url + , defaultHttpConfig + , header + , https + , jsonResponse + , queryParam + , renderUrl + , req + , responseBody + , runReq + , (/:) + , (/~) + ) +import Network.HTTP.Types (statusCode) +import System.IO (hPutStrLn, stderr) +import Text.Read (readMaybe) -import qualified Data.Text as T +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T + -- | Solana Beach API Configuration data Config = Config - { cApiKey :: T.Text + { cApiKey :: T.Text -- ^ Your API Key. -- Get one here: https://github.com/solana-beach/api , cAccountPubKey :: T.Text @@ -96,11 +105,13 @@ } deriving (Show, Read, Eq) + -- | Create a program config from the API key & the target account's -- pubkey. mkConfig :: String -> String -> Config -mkConfig (T.pack -> cApiKey) (T.pack -> cAccountPubKey) = Config { .. } +mkConfig (T.pack -> cApiKey) (T.pack -> cAccountPubKey) = Config {..} + -- | Base URL to Solana Beach's API baseUrl :: Url 'Https baseUrl = https "api.solanabeach.io" /: "v1" @@ -108,62 +119,71 @@ -- | Get the staking accounts for the 'cAccountPubKey'. getAccountStakes - :: (MonadIO m, MonadReader Config m) => m (APIResponse StakingAccounts) + :: (MonadReader Config m, MonadCatch m, MonadIO m) + => m (APIResponse StakingAccounts) getAccountStakes = do pubkey <- asks cAccountPubKey getReq (baseUrl /: "account" /~ pubkey /: "stakes") mempty + -- | Single Result Page of Staking Accounts Query. data StakingAccounts = StakingAccounts - { saResults :: [StakingAccount] + { saResults :: [StakingAccount] -- ^ The returned staking accounts , saTotalPages :: Integer -- ^ The total number of pages for the Account's PubKey. } deriving (Show, Read, Eq, Generic) + instance FromJSON StakingAccounts where parseJSON = withObject "StakingAccounts" $ \o -> do - saResults <- o .: "data" + saResults <- o .: "data" saTotalPages <- o .: "totalPages" - return StakingAccounts { .. } + return StakingAccounts {..} + -- | A single Staking Account. data StakingAccount = StakingAccount - { saPubKey :: StakingPubKey + { saPubKey :: StakingPubKey -- ^ The Staking Accounts PubKey - , saLamports :: Lamports + , saLamports :: Lamports -- ^ The Balance of the Staking Account , saValidatorName :: T.Text -- ^ The Name of the Staking Account's Validator } deriving (Show, Read, Eq, Generic) + instance FromJSON StakingAccount where parseJSON = withObject "StakingAccount" $ \o -> do - saPubKey <- o .: "pubkey" >>= (.: "address") - saLamports <- o .: "lamports" + saPubKey <- o .: "pubkey" >>= (.: "address") + saLamports <- o .: "lamports" saValidatorName <- o - .: "data" - >>= (.: "stake") - >>= (.: "delegation") - >>= (.: "validatorInfo") - >>= (.: "name") - return StakingAccount { .. } + .: "data" + >>= (.: "stake") + >>= (.: "delegation") + >>= (.: "validatorInfo") + >>= (.: "name") + return StakingAccount {..} + -- | A PubKey for a Staking Account. -newtype StakingPubKey = - StakingPubKey { fromStakingPubKey :: T.Text } deriving (Show, Read, Eq, Generic, FromJSON) +newtype StakingPubKey = StakingPubKey {fromStakingPubKey :: T.Text} + deriving (Show, Read, Eq, Generic, FromJSON) + -- | An amount of Lamports, each of which represent 0.000000001 SOL. -newtype Lamports = - Lamports { fromLamports :: Integer } deriving (Show, Read, Eq, Generic, FromJSON) +newtype Lamports = Lamports {fromLamports :: Integer} + deriving (Show, Read, Eq, Num, Generic, FromJSON) + -- | Render an amount of 'Lamports' as text, converting it to SOL. renderLamports :: Lamports -> T.Text renderLamports = T.pack . formatScientific Fixed (Just 9) . scientificLamports + -- | Convert Lamports into Scientific representation of SOL. scientificLamports :: Lamports -> Scientific scientificLamports = (* 0.000000001) . fromInteger . fromLamports @@ -171,40 +191,45 @@ -- | Get the staking rewards with a staking account's pubkey. getStakeRewards - :: (MonadIO m, MonadReader Config m) + :: (MonadReader Config m, MonadCatch m, MonadIO m) => StakingPubKey -> Maybe Integer -> m (APIResponse [StakeReward]) getStakeRewards (StakingPubKey stakeAccountPubkey) mbEpochCursor = do - getReq (baseUrl /: "account" /: stakeAccountPubkey /: "stake-rewards") - (queryParam "cursor" mbEpochCursor) + getReq + (baseUrl /: "account" /: stakeAccountPubkey /: "stake-rewards") + (queryParam "cursor" mbEpochCursor) + -- | Get all the staking rewards for the given account. -- -- The API's @stake-rewards@ route only returns a maximum of 5 rewards, so -- we have to use the earliest epoch as the @cursor@ in an additional -- request to see if there are any more rewards. getAllStakeRewards - :: (MonadIO m, MonadReader Config m) + :: (MonadReader Config m, MonadCatch m, MonadIO m) => StakingPubKey -> m ([APIError], [StakeReward]) getAllStakeRewards pubkey = - getStakeRewards pubkey Nothing >>= runApi >>= getStakeRewardsUntil - pubkey - (const True) - ([], []) + getStakeRewards pubkey Nothing + >>= runApi + >>= getStakeRewardsUntil + pubkey + (const True) + ([], []) + -- | Get the year's worth of staking rewards for the given account. getYearsStakeRewards - :: (MonadIO m, MonadReader Config m) + :: (MonadReader Config m, MonadCatch m, MonadIO m) => StakingPubKey -> Integer -> m ([APIError], [StakeReward]) getYearsStakeRewards pubkey year = - fmap (second $ filter ((== year) . rewardYear)) - $ getStakeRewards pubkey Nothing - >>= runApi - >>= getStakeRewardsUntil pubkey stopAfterYear ([], []) + fmap (second $ filter ((== year) . rewardYear)) $ + getStakeRewards pubkey Nothing + >>= runApi + >>= getStakeRewardsUntil pubkey stopAfterYear ([], []) where rewardYear :: StakeReward -> Integer rewardYear = @@ -218,69 +243,77 @@ stopAfterYear rewards = let years = map rewardYear rewards in any (< year) years + -- | Fetch staking rewards until we get less than 5 rewards or the general -- predicate returns true. getStakeRewardsUntil - :: (MonadIO m, MonadReader Config m) + :: (MonadReader Config m, MonadCatch m, MonadIO m) => StakingPubKey -> ([StakeReward] -> Bool) -> ([APIError], [StakeReward]) -> Either APIError [StakeReward] -> m ([APIError], [StakeReward]) getStakeRewardsUntil pubkey cond (errs, rws) = \case - Left err -> return (err : errs, rws) - Right rewards -> if length rewards < 5 || cond rewards - then return (errs, rewards <> rws) - else - let minEpoch = minimum $ map srEpoch rewards - in getStakeRewards pubkey (Just minEpoch) - >>= runApi - >>= getStakeRewardsUntil pubkey cond (errs, rewards <> rws) + Left err -> return (err : errs, rws) + Right rewards -> + if null rewards || cond rewards + then return (errs, rewards <> rws) + else + let minEpoch = minimum $ map srEpoch rewards + in getStakeRewards pubkey (Just minEpoch) + >>= runApi + >>= getStakeRewardsUntil pubkey cond (errs, rewards <> rws) -- | A Staking Reward Payment. data StakeReward = StakeReward - { srEpoch :: Integer + { srEpoch :: Integer -- ^ The Epoch the reward was paid. - , srSlot :: Integer + , srSlot :: Integer -- ^ The 'Block' number of the reward. - , srAmount :: Lamports + , srAmount :: Lamports -- ^ The total number of 'Lamports' awarded. , srTimestamp :: POSIXTime } deriving (Show, Read, Eq, Generic) + instance FromJSON StakeReward where parseJSON = withObject "StakeReward" $ \o -> do - srEpoch <- o .: "epoch" - srSlot <- o .: "effectiveSlot" - srAmount <- o .: "amount" + srEpoch <- o .: "epoch" + srSlot <- o .: "effectiveSlot" + srAmount <- o .: "amount" srTimestamp <- o .: "timestamp" - return StakeReward { .. } + return StakeReward {..} + -- | Get information about a specific block number. getBlock - :: (MonadIO m, MonadReader Config m) => Integer -> m (APIResponse Block) + :: (MonadReader Config m, MonadCatch m, MonadIO m) + => Integer + -> m (APIResponse Block) getBlock blockNum = do getReq (baseUrl /: "block" /~ blockNum) mempty + -- | A single block on the Solana blockchain. data Block = Block - { bNumber :: Integer + { bNumber :: Integer -- ^ The blocks number. , bBlockTime :: POSIXTime -- ^ The blocks absolute timestamp. } deriving (Show, Read, Eq, Generic) + instance FromJSON Block where parseJSON = withObject "Block" $ \o -> do - bNumber <- o .: "blocknumber" + bNumber <- o .: "blocknumber" bBlockTime <- (o .: "blocktime") - >>= fmap (fromInteger . (truncate @Scientific)) - . (.: "absolute") - return Block { .. } + >>= fmap (fromInteger . (truncate @Scientific)) + . (.: "absolute") + return Block {..} -- | Generic GET request to the Solana Beach API with up to 5 retries for @@ -289,7 +322,7 @@ -- Note: Prints to 'stderr' when waiting for request to finish processing. getReq :: forall m a - . (MonadReader Config m, MonadIO m, FromJSON a) + . (MonadReader Config m, FromJSON a, MonadIO m, MonadCatch m) => Url 'Https -> Option 'Https -> m (APIResponse a) @@ -298,65 +331,103 @@ maxRetries :: Integer maxRetries = 5 fetchWithRetries :: Integer -> m (APIResponse a) - fetchWithRetries retryCount = if retryCount >= maxRetries - then return $ ErrorResponse $ RetriesExceeded $ renderUrl endpoint - else do - apikey <- asks cApiKey - let authHeader = - header "Authorization" $ "Bearer: " <> encodeUtf8 apikey - respBody <- responseBody <$> runReq - defaultHttpConfig - (req GET endpoint NoReqBody jsonResponse $ authHeader <> options - ) - case respBody of - ProcessingResponse -> do - liftIO $ hPutStrLn - stderr - "Waiting for API to finish processing request..." - liftIO $ threadDelay $ 10 * 1000000 - fetchWithRetries (retryCount + 1) - _ -> return respBody - - + fetchWithRetries retryCount = + if retryCount >= maxRetries + then return $ ErrorResponse $ RetriesExceeded $ renderUrl endpoint + else do + apikey <- asks cApiKey + let authHeader = + header "Authorization" $ "Bearer: " <> encodeUtf8 apikey + respBody <- + catchRateLimitError $ + runReq + defaultHttpConfig + ( req GET endpoint NoReqBody jsonResponse $ authHeader <> options + ) + case respBody of + ProcessingResponse -> do + liftIO $ + hPutStrLn + stderr + "Waiting for API to finish processing request..." + liftIO $ threadDelay $ 10 * 1000000 + fetchWithRetries (retryCount + 1) + RateLimitResponse wait -> do + liftIO $ + hPutStrLn stderr $ + "Exceeded rate limit, waiting " + <> show wait + <> " seconds before retrying..." + liftIO $ threadDelay $ wait * 1000000 + fetchWithRetries retryCount + _ -> return respBody + catchRateLimitError + :: (FromJSON (HttpResponseBody b)) + => (HttpResponse b) + => m b + -> m (HttpResponseBody b) + catchRateLimitError = + try >=> \case + Left e@(VanillaHttpException (HttpExceptionRequest _ (StatusCodeException resp body))) -> + if statusCode (responseStatus resp) == 429 + then + either (liftIO . throwIO . JsonHttpException) return $ + eitherDecode $ + LBS.fromStrict body + else liftIO $ throwIO e + Left e -> liftIO $ throwIO e + Right r -> return $ responseBody r -- | Wrapper around error & processing responses from the API. data APIResponse a = SuccessfulReponse a | ProcessingResponse + | RateLimitResponse Int | ErrorResponse APIError deriving (Show, Read, Eq) + -- | Attempts to parse a processing response, then an error response, -- & finally the inner @a@ response. -instance FromJSON a => FromJSON (APIResponse a) where +instance (FromJSON a) => FromJSON (APIResponse a) where parseJSON v = case v of Object o -> do o .:? "err" >>= \case - Just errMsg -> o .:? "processing" >>= \case - Nothing -> return $ ErrorResponse $ APIError errMsg - Just (_ :: Bool) -> return ProcessingResponse + Just errMsg -> + o .:? "processing" >>= \case + Nothing -> + o .:? "retry" >>= \case + Just (readMaybe -> Just i) -> + return $ RateLimitResponse i + _ -> return $ ErrorResponse $ APIError errMsg + Just (_ :: Bool) -> return ProcessingResponse Nothing -> fmap SuccessfulReponse . parseJSON $ Object o _ -> SuccessfulReponse <$> parseJSON v + -- | Evaluate an API response. -runApi :: Monad m => APIResponse a -> m (Either APIError a) +runApi :: (Monad m) => APIResponse a -> m (Either APIError a) runApi = runExceptT . raiseAPIError + -- | Pull the inner value out of an 'APIResponse' or throw the respective -- 'APIError'. -raiseAPIError :: MonadError APIError m => APIResponse a -> m a +raiseAPIError :: (MonadError APIError m) => APIResponse a -> m a raiseAPIError = \case SuccessfulReponse v -> return v ProcessingResponse -> throwError $ APIError "Request cancelled during processing wait." + RateLimitResponse i -> throwError $ RateLimitError i ErrorResponse err -> throwError err -- | Potential error responses from the Solana Beach API. data APIError - = APIError T.Text - -- ^ Generic API error with message. - | RetriesExceeded T.Text - -- ^ Exceeded maximum number of 'ProcessingResponse' retries. + = -- | Generic API error with message. + APIError T.Text + | -- | Exceeded maximum number of 'ProcessingResponse' retries. + RetriesExceeded T.Text + | -- | Rate limiting 429 error. + RateLimitError Int deriving (Show, Read, Eq, Generic) diff --git a/src/Console/SolanaStaking/CoinTracking.hs b/src/Console/SolanaStaking/CoinTracking.hs --- a/src/Console/SolanaStaking/CoinTracking.hs +++ b/src/Console/SolanaStaking/CoinTracking.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RecordWildCards #-} -{-| Generate & write/print CoinTracking import files. --} +-- | Generate & write/print CoinTracking import files. module Console.SolanaStaking.CoinTracking ( makeCoinTrackingImport , writeOrPrintImportData @@ -9,25 +8,27 @@ , sol ) where -import Control.Monad ( (>=>) ) -import Data.Time ( utcToLocalZonedTime ) -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) -import Web.CoinTracking.Imports ( Amount(..) - , CTImportData(..) - , CTTransactionType(Staking) - , Currency(..) - , coinTrackingCsvImport - , writeImportDataToFile - ) +import Control.Monad ((>=>)) +import Data.Time (utcToLocalZonedTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Web.CoinTracking.Imports + ( Amount (..) + , CTImportData (..) + , CTTransactionType (Staking) + , Currency (..) + , coinTrackingCsvImport + , writeImportDataToFile + ) -import Console.SolanaStaking.Api ( StakeReward(..) - , StakingAccount(..) - , StakingPubKey(..) - , scientificLamports - ) +import Console.SolanaStaking.Api + ( StakeReward (..) + , StakingAccount (..) + , StakingPubKey (..) + , scientificLamports + ) -import qualified Data.ByteString.Lazy.Char8 as LBC -import qualified Data.Text as T +import Data.ByteString.Lazy.Char8 qualified as LBC +import Data.Text qualified as T -- | Generate the Import file for CoinTracking & write to destination or @@ -35,32 +36,40 @@ makeCoinTrackingImport :: FilePath -> [(StakingAccount, StakeReward)] -> IO () makeCoinTrackingImport dest = makeImportData >=> writeOrPrintImportData dest + -- | Write or print the generated import data. writeOrPrintImportData :: FilePath -> [CTImportData] -> IO () -writeOrPrintImportData dest importData = if dest == "-" - then LBC.putStrLn $ coinTrackingCsvImport importData - else writeImportDataToFile dest importData +writeOrPrintImportData dest importData = + if dest == "-" + then LBC.putStrLn $ coinTrackingCsvImport importData + else writeImportDataToFile dest importData + -- | Turn a 'StakeReward' into a 'CTImportData', localizing the reward -- time. makeImportData :: [(StakingAccount, StakeReward)] -> IO [CTImportData] makeImportData = mapM $ \(StakingAccount {..}, StakeReward {..}) -> do zonedTime <- utcToLocalZonedTime $ posixSecondsToUTCTime srTimestamp - return CTImportData - { ctidType = Staking - , ctidBuy = Just $ Amount (scientificLamports srAmount) sol - , ctidSell = Nothing - , ctidFee = Nothing - , ctidExchange = "Solana Staking" - , ctidGroup = "Staking" - , ctidComment = "Imported from solana-staking-csvs" - , ctidDate = zonedTime - , ctidTradeId = - "SOL-STAKE-" <> fromStakingPubKey saPubKey <> "-" <> T.pack - (show srEpoch) - , ctidBuyValue = Nothing - , ctidSellValue = Nothing - } + return + CTImportData + { ctidType = Staking + , ctidBuy = Just $ Amount (scientificLamports srAmount) sol + , ctidSell = Nothing + , ctidFee = Nothing + , ctidExchange = "Solana Staking" + , ctidGroup = "Staking" + , ctidComment = "Imported from solana-staking-csvs" + , ctidDate = zonedTime + , ctidTradeId = + "SOL-STAKE-" + <> fromStakingPubKey saPubKey + <> "-" + <> T.pack + (show srEpoch) + , ctidBuyValue = Nothing + , ctidSellValue = Nothing + } + -- | @SOL@ currency with the @SOL2@ ticker & 9 decimals of precision. sol :: Currency diff --git a/src/Console/SolanaStaking/Csv.hs b/src/Console/SolanaStaking/Csv.hs --- a/src/Console/SolanaStaking/Csv.hs +++ b/src/Console/SolanaStaking/Csv.hs @@ -1,76 +1,79 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} -{-| Types responsible for CSV generation. --} +-- | Types responsible for CSV generation. module Console.SolanaStaking.Csv ( makeCsvContents - , ExportData(..) + , ExportData (..) , toExportData ) where -import Data.Csv ( (.=) - , DefaultOrdered(..) - , EncodeOptions(..) - , ToNamedRecord(..) - , defaultEncodeOptions - , encodeDefaultOrderedByNameWith - , namedRecord - ) -import Data.Time ( defaultTimeLocale - , formatTime - ) -import Data.Time.Clock.POSIX ( POSIXTime - , posixSecondsToUTCTime - ) +import Data.Csv + ( DefaultOrdered (..) + , EncodeOptions (..) + , ToNamedRecord (..) + , defaultEncodeOptions + , encodeDefaultOrderedByNameWith + , namedRecord + , (.=) + ) +import Data.Time (defaultTimeLocale, formatTime) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) -import Console.SolanaStaking.Api ( StakeReward(..) - , StakingAccount(..) - , StakingPubKey(..) - , renderLamports - ) +import Console.SolanaStaking.Api + ( StakeReward (..) + , StakingAccount (..) + , StakingPubKey (..) + , renderLamports + ) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T -- | Represents a single row of CSV data. data ExportData = ExportData - { edTime :: T.Text - , edAmount :: T.Text + { edTime :: T.Text + , edAmount :: T.Text , edStakeAccount :: T.Text - , edEpoch :: Integer + , edEpoch :: Integer } deriving (Show, Read, Eq, Ord) + -- | Remove the @ed@ prefixes from the field names. instance ToNamedRecord ExportData where - toNamedRecord ExportData {..} = namedRecord - [ "time" .= edTime - , "amount" .= edAmount - , "stakeAccount" .= edStakeAccount - , "epoch" .= edEpoch - ] + toNamedRecord ExportData {..} = + namedRecord + [ "time" .= edTime + , "amount" .= edAmount + , "stakeAccount" .= edStakeAccount + , "epoch" .= edEpoch + ] + -- | Column order is @time, amount, stakeAccount, epoch@. instance DefaultOrdered ExportData where headerOrder _ = ["time", "amount", "stakeAccount", "epoch"] + -- | Convert an Account & Reward into a CSV row. toExportData :: (StakingAccount, StakeReward) -> ExportData -toExportData (StakingAccount {..}, StakeReward {..}) = ExportData - { edTime = formatTimestamp srTimestamp - , edAmount = renderLamports srAmount - , edStakeAccount = fromStakingPubKey saPubKey - , edEpoch = srEpoch - } +toExportData (StakingAccount {..}, StakeReward {..}) = + ExportData + { edTime = formatTimestamp srTimestamp + , edAmount = renderLamports srAmount + , edStakeAccount = fromStakingPubKey saPubKey + , edEpoch = srEpoch + } where formatTimestamp :: POSIXTime -> T.Text formatTimestamp = T.pack . formatTime defaultTimeLocale "%F %T%Z" . posixSecondsToUTCTime + -- | Build the CSV contents with a header row. makeCsvContents :: [(StakingAccount, StakeReward)] -> LBS.ByteString makeCsvContents = - encodeDefaultOrderedByNameWith defaultEncodeOptions { encUseCrLf = False } + encodeDefaultOrderedByNameWith defaultEncodeOptions {encUseCrLf = False} . map toExportData diff --git a/src/Console/SolanaStaking/Main.hs b/src/Console/SolanaStaking/Main.hs --- a/src/Console/SolanaStaking/Main.hs +++ b/src/Console/SolanaStaking/Main.hs @@ -1,56 +1,47 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} -{-| This module contains the @main@ function used by the exectuable. --} +-- | This module contains the @main@ function used by the exectuable. module Console.SolanaStaking.Main ( run , getArgs - , Args(..) + , Args (..) ) where -import Control.Monad ( (<=<) - , forM - , unless - ) -import Control.Monad.Except ( ExceptT - , runExceptT - ) -import Control.Monad.Reader ( ReaderT - , liftIO - , runReaderT - ) -import Data.Bifunctor ( bimap - , second - ) -import Data.List ( sortOn ) -import Data.Maybe ( fromMaybe ) -import Data.Version ( showVersion ) -import System.Console.CmdArgs ( (&=) - , Data - , Typeable - , argPos - , cmdArgs - , def - , explicit - , help - , helpArg - , name - , program - , summary - , typ - ) -import System.IO ( hPutStrLn - , stderr - ) +import Control.Monad (foldM, forM, unless, (<=<)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Reader (MonadIO, ReaderT, liftIO, runReaderT) +import Data.Bifunctor (bimap, second) +import Data.List (sortOn) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time (LocalTime (..), ZonedTime (..), utcToLocalZonedTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Version (showVersion) +import System.Console.CmdArgs + ( Data + , Typeable + , argPos + , cmdArgs + , def + , explicit + , help + , helpArg + , name + , program + , summary + , typ + , (&=) + ) +import System.IO (hPutStrLn, stderr) -import Console.SolanaStaking.Api -import Console.SolanaStaking.CoinTracking - ( makeCoinTrackingImport ) -import Console.SolanaStaking.Csv ( makeCsvContents ) -import Paths_solana_staking_csvs ( version ) +import Console.SolanaStaking.Api +import Console.SolanaStaking.CoinTracking (makeCoinTrackingImport) +import Console.SolanaStaking.Csv (makeCsvContents) +import Paths_solana_staking_csvs (version) -import qualified Data.ByteString.Lazy as LBS +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as M +import Data.Text qualified as T -- | Pull staking rewards data for the account & print a CSV to stdout. @@ -63,78 +54,123 @@ -- Grab rewards for each stake account (stakeErrors, stakeRewards) <- fmap (bimap concat concat . unzip) . forM stakes $ \sa -> do - - second (map (sa, )) - <$> maybe (getAllStakeRewards (saPubKey sa)) - (getYearsStakeRewards $ saPubKey sa) - argYear + second (map (sa,)) + <$> maybe + (getAllStakeRewards (saPubKey sa)) + (getYearsStakeRewards $ saPubKey sa) + argYear unless (null stakeErrors) . liftIO $ do hPutStrLn stderr "Got errors while fetching stake rewards:" mapM_ (hPutStrLn stderr . ("\t" <>) . show) stakeErrors -- Write the CSV let orderedRewards = sortOn (srTimestamp . snd) stakeRewards - outputFile = fromMaybe "-" argOutputFile + aggregator = if argAggregate then aggregateRewards else return + outputFile = fromMaybe "-" argOutputFile + rewards <- aggregator orderedRewards if argCoinTracking - then liftIO $ makeCoinTrackingImport outputFile orderedRewards + then liftIO $ makeCoinTrackingImport outputFile rewards else do - let output = makeCsvContents orderedRewards + let output = makeCsvContents rewards if outputFile == "-" then liftIO $ LBS.putStr output else liftIO $ LBS.writeFile outputFile output where runner :: ReaderT Config (ExceptT APIError IO) a -> IO (Either APIError a) runner = runExceptT . flip runReaderT (mkConfig argApiKey argPubKey) + aggregateRewards :: (MonadIO m) => [(StakingAccount, StakeReward)] -> m [(StakingAccount, StakeReward)] + aggregateRewards = + fmap (mapMaybe (aggregate . snd) . M.toList) + . foldM + ( \acc r -> do + rewardTime <- liftIO . utcToLocalZonedTime $ posixSecondsToUTCTime $ srTimestamp $ snd r + return $ + M.insertWith + (<>) + (localDay $ zonedTimeToLocalTime rewardTime) + [r] + acc + ) + M.empty + aggregate :: [(StakingAccount, StakeReward)] -> Maybe (StakingAccount, StakeReward) + aggregate = \case + [] -> Nothing + rs -> + Just + ( StakingAccount + { saValidatorName = "AGGREGATE-" <> T.pack (show $ length rs) + , saPubKey = StakingPubKey $ T.pack argPubKey + , saLamports = sum $ map (saLamports . fst) rs + } + , StakeReward + { srTimestamp = minimum $ map (srTimestamp . snd) rs + , srSlot = srSlot $ snd $ head rs + , srEpoch = srEpoch $ snd $ head rs + , srAmount = sum $ map (srAmount . snd) rs + } + ) + -- | CLI arguments supported by the executable. data Args = Args - { argApiKey :: String + { argApiKey :: String -- ^ Solana Beach API Key - , argPubKey :: String + , argPubKey :: String -- ^ Delegator's PubKey. - , argOutputFile :: Maybe String + , argOutputFile :: Maybe String -- ^ Optional output file. 'Nothing' or @'Just' "-"@ means print to -- 'System.IO.stdout'. , argCoinTracking :: Bool -- ^ Flag to enable writing/printing files formatted for CoinTracking -- Imports. - , argYear :: Maybe Integer + , argYear :: Maybe Integer -- ^ Year to limit output to. + , argAggregate :: Bool + -- ^ Aggregate rewards into single-day transactions. } deriving (Show, Read, Eq, Data, Typeable) + -- | Parse the CLI arguments with 'System.Console.CmdArgs'. getArgs :: IO Args getArgs = cmdArgs argSpec + argSpec :: Args argSpec = Args - { argApiKey = def &= argPos 0 &= typ "API_KEY" - , argPubKey = def &= argPos 1 &= typ "ACCOUNT_PUBKEY" - , argOutputFile = - Nothing + { argApiKey = def &= argPos 0 &= typ "API_KEY" + , argPubKey = def &= argPos 1 &= typ "ACCOUNT_PUBKEY" + , argOutputFile = + Nothing &= help "File to write the export to. Default: stdout" &= explicit &= name "output-file" &= name "o" &= typ "FILE" - , argCoinTracking = False - &= help "Generate a CoinTracking Import file." - &= explicit - &= name "cointracking" - , argYear = Nothing - &= help "Limit to given year" - &= explicit - &= name "y" - &= name "year" - &= typ "YYYY" - } + , argCoinTracking = + False + &= help "Generate a CoinTracking Import file." + &= explicit + &= name "cointracking" + , argYear = + Nothing + &= help "Limit to given year" + &= explicit + &= name "y" + &= name "year" + &= typ "YYYY" + , argAggregate = + False + &= help "Output one aggregate row per day." + &= explicit + &= name "aggregate" + } &= summary - ( "solana-staking-csvs v" - <> showVersion version - <> ", Pavan Rikhi 2021" - ) + ( "solana-staking-csvs v" + <> showVersion version + <> ", Pavan Rikhi 2021-2024" + ) &= program "solana-staking-csvs" &= helpArg [name "h"] &= help "Generate CSV Exports of your Solana Staking Rewards." 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 Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range main :: IO () @@ -23,9 +23,10 @@ properties :: TestTree -properties = testGroup - "Properties" - [testProperty "Addition is Communative" testAdditionCommunative] +properties = + testGroup + "Properties" + [testProperty "Addition is Communative" testAdditionCommunative] where testAdditionCommunative :: Property testAdditionCommunative = property $ do