feat: support of stake validators and provider function to get reward…

…s information given stake address

Related to #294

atlas-cardano.cabal

@@ -128,7 +128,9 @@ library
     GeniusYield.Types.Script
     GeniusYield.Types.Slot
     GeniusYield.Types.SlotConfig
+    GeniusYield.Types.StakeAddressInfo
     GeniusYield.Types.StakeKeyHash
+    GeniusYield.Types.StakePoolId
     GeniusYield.Types.Time
     GeniusYield.Types.Tx
     GeniusYield.Types.TxBody

src/GeniusYield/GYConfig.hs

@@ -37,6 +37,7 @@ import qualified GeniusYield.Providers.Blockfrost as Blockfrost
 import qualified GeniusYield.Providers.Katip      as Katip
 import qualified GeniusYield.Providers.Kupo       as KupoApi
 import qualified GeniusYield.Providers.Maestro    as MaestroApi
+import           GeniusYield.Providers.Node       (nodeStakeAddressInfo)
 import qualified GeniusYield.Providers.Node       as Node
 import           GeniusYield.Types
 
@@ -153,7 +154,7 @@ withCfgProviders
     ns
     f =
     do
-      (gyGetParameters, gySlotActions', gyQueryUTxO', gyLookupDatum, gySubmitTx, gyAwaitTxConfirmed) <- case cfgCoreProvider of
+      (gyGetParameters, gySlotActions', gyQueryUTxO', gyLookupDatum, gySubmitTx, gyAwaitTxConfirmed, gyGetStakeAddressInfo) <- case cfgCoreProvider of
         GYNodeKupo path kupoUrl -> do
           let info = nodeConnectInfo path cfgNetworkId
               era = networkIdToEra cfgNetworkId
@@ -166,6 +167,7 @@ withCfgProviders
             , KupoApi.kupoLookupDatum kEnv
             , Node.nodeSubmitTx info
             , KupoApi.kupoAwaitTxConfirmed kEnv
+            , nodeStakeAddressInfo info
             )
         GYMaestro (Confidential apiToken) turboSubmit -> do
           maestroApiEnv <- MaestroApi.networkIdToMaestroEnv apiToken cfgNetworkId
@@ -183,6 +185,7 @@ withCfgProviders
             , MaestroApi.maestroLookupDatum maestroApiEnv
             , MaestroApi.maestroSubmitTx (Just True == turboSubmit) maestroApiEnv
             , MaestroApi.maestroAwaitTxConfirmed maestroApiEnv
+            , MaestroApi.maestroStakeAddressInfo maestroApiEnv
             )
         GYBlockfrost (Confidential key) -> do
           let proj = Blockfrost.networkIdToProject cfgNetworkId key
@@ -200,6 +203,7 @@ withCfgProviders
             , Blockfrost.blockfrostLookupDatum proj
             , Blockfrost.blockfrostSubmitTx proj
             , Blockfrost.blockfrostAwaitTxConfirmed proj
+            , Blockfrost.blockfrostStakeAddressInfo proj
             )
 
       bracket (Katip.mkKatipLog ns cfgLogging) logCleanUp $ \gyLog' -> do

src/GeniusYield/Providers/Blockfrost.hs

@@ -9,6 +9,7 @@ module GeniusYield.Providers.Blockfrost
     , blockfrostGetSlotOfCurrentBlock
     , blockfrostSubmitTx
     , blockfrostAwaitTxConfirmed
+    , blockfrostStakeAddressInfo
     , networkIdToProject
     ) where
 
@@ -446,6 +447,18 @@ blockfrostLookupDatum p dh = do
     handler other                                = handleBlockfrostError locationIdent $ Just <$> other
     locationIdent = "LookupDatum"
 
+-------------------------------------------------------------------------------
+-- Account info
+-------------------------------------------------------------------------------
+
+blockfrostStakeAddressInfo :: Blockfrost.Project -> GYStakeAddress -> IO GYStakeAddressInfo
+blockfrostStakeAddressInfo p saddr = do
+  accInfo <- Blockfrost.runBlockfrost p (Blockfrost.getAccount (Blockfrost.mkAddress $ stakeAddressToText saddr)) >>= handleBlockfrostError "Account"
+  pure $ GYStakeAddressInfo
+    { gyStakeAddressInfoDelegatedPool = Blockfrost._accountInfoPoolId accInfo >>= stakePoolIdFromTextMaybe . Blockfrost.unPoolId
+    , gyStakeAddressInfoAvailableRewards = fromInteger $ lovelacesToInteger $ Blockfrost._accountInfoWithdrawableAmount accInfo
+    }
+
 -------------------------------------------------------------------------------
 -- Auxiliary functions
 -------------------------------------------------------------------------------

src/GeniusYield/Providers/Maestro.hs

@@ -21,6 +21,7 @@ module GeniusYield.Providers.Maestro
   , maestroLookupDatum
   , maestroUtxosAtAddressesWithDatums
   , maestroUtxosAtPaymentCredentialsWithDatums
+  , maestroStakeAddressInfo
   ) where
 
 import qualified Cardano.Api                          as Api
@@ -42,6 +43,7 @@ import           GeniusYield.Providers.Common
 import           GeniusYield.Types
 import           GHC.Natural                          (wordToNatural)
 import qualified Maestro.Client.V1                    as Maestro
+import qualified Maestro.Client.V1.Accounts           as Maestro
 import qualified Maestro.Types.V1                     as Maestro
 import qualified Ouroboros.Consensus.HardFork.History as Ouroboros
 import qualified PlutusTx.Builtins                    as Plutus
@@ -534,3 +536,20 @@ maestroLookupDatum env dh = do
     -- This particular error is fine in this case, we can just return 'Nothing'.
     handler (Left Maestro.MaestroNotFound) = pure Nothing
     handler other = handleMaestroError locationIdent $ Just <$> other
+
+-------------------------------------------------------------------------------
+-- Account info
+-------------------------------------------------------------------------------
+
+-- | Returns the 'GYStakeAddressInfo' queried from Maestro.
+maestroStakeAddressInfo :: Maestro.MaestroEnv 'Maestro.V1 -> GYStakeAddress -> IO GYStakeAddressInfo
+maestroStakeAddressInfo env saddr = do
+  handler <=< try $ Maestro.getTimestampedData <$> Maestro.accountInfo env (coerce stakeAddressToText saddr)
+  where
+    -- This particular error is fine.
+    handler (Left Maestro.MaestroNotFound) = pure $ GYStakeAddressInfo Nothing 0
+    handler other = handleMaestroError "AccountInfo" $ other <&> \accInfo ->
+      GYStakeAddressInfo
+        { gyStakeAddressInfoDelegatedPool = Maestro.accountInfoDelegatedPool accInfo >>= stakePoolIdFromTextMaybe . coerce
+        , gyStakeAddressInfoAvailableRewards = fromIntegral $ Maestro.accountInfoRewardsAvailable accInfo
+        }

src/GeniusYield/Providers/Node.hs

@@ -16,6 +16,7 @@ module GeniusYield.Providers.Node
     , nodeUtxosAtAddress
     , nodeUtxoAtTxOutRef
     , nodeUtxosAtTxOutRefs
+    , nodeStakeAddressInfo
     -- * Auxiliary
     , networkIdToLocalNodeConnectInfo
     ) where
@@ -24,15 +25,14 @@ import qualified Cardano.Api                                       as Api
 import qualified Cardano.Api.Shelley                               as Api.S
 import           Cardano.Slotting.Time                             (SystemStart)
 import           Control.Exception                                 (throwIO)
+import qualified Data.Map.Strict                                   as Map
 import qualified Data.Set                                          as Set
 import qualified Data.Text                                         as Txt
-
-import           Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..))
-
 import           GeniusYield.CardanoApi.Query
 import           GeniusYield.Providers.Common                      (SubmitTxException (SubmitTxException))
 import           GeniusYield.TxBuilder.Errors
 import           GeniusYield.Types
+import           Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..))
 
 -------------------------------------------------------------------------------
 -- Submit
@@ -105,6 +105,16 @@ stakePools :: GYEra -> Api.LocalNodeConnectInfo Api.CardanoMode -> IO (Set.Set A
 stakePools GYAlonzo  info = queryAlonzoEra  info Api.QueryStakePools
 stakePools GYBabbage info = queryBabbageEra info Api.QueryStakePools
 
+nodeStakeAddressInfo :: Api.LocalNodeConnectInfo Api.CardanoMode -> GYStakeAddress -> IO GYStakeAddressInfo
+nodeStakeAddressInfo info saddr = resolveStakeAddressInfoFromApi saddr <$> queryBabbageEra info (Api.QueryStakeAddresses (Set.singleton $ stakeCredentialToApi $ stakeAddressToCredential saddr) (Api.localNodeNetworkId info))
+
+resolveStakeAddressInfoFromApi :: GYStakeAddress -> (Map.Map Api.StakeAddress Api.Lovelace, Map.Map Api.StakeAddress Api.S.PoolId) -> GYStakeAddressInfo
+resolveStakeAddressInfoFromApi (stakeAddressToApi -> stakeAddr) (rewards, delegations) =
+    GYStakeAddressInfo
+        { gyStakeAddressInfoAvailableRewards = fromIntegral $ Map.findWithDefault 0 stakeAddr rewards
+        , gyStakeAddressInfoDelegatedPool = stakePoolIdFromApi <$> Map.lookup stakeAddr delegations
+        }
+
 systemStart :: Api.LocalNodeConnectInfo Api.CardanoMode -> IO SystemStart
 systemStart info = queryCardanoMode info Api.QuerySystemStart
 

src/GeniusYield/Test/Privnet/Ctx.hs

@@ -188,6 +188,7 @@ ctxProviders ctx = GYProviders
     , gyGetParameters    = ctxGetParams ctx
     , gyQueryUTxO        = ctxQueryUtxos ctx
     , gyLog'             = ctxLog ctx
+    , gyGetStakeAddressInfo = nodeStakeAddressInfo (ctxInfo ctx)
     }
 
 submitTx :: Ctx -> User -> GYTxBody -> IO GYTxId

src/GeniusYield/TxBuilder/Class.hs

@@ -97,7 +97,7 @@ import           GeniusYield.Types.TxWdrl     (GYTxWdrl (..))
 
 -- | Class of monads for querying chain data.
 class MonadError GYTxMonadException m => GYTxQueryMonad m where
-    {-# MINIMAL networkId, lookupDatum, (utxoAtTxOutRef | utxosAtTxOutRefs), utxosAtAddress, utxosAtPaymentCredential, slotConfig, slotOfCurrentBlock, logMsg #-}
+    {-# MINIMAL networkId, lookupDatum, (utxoAtTxOutRef | utxosAtTxOutRefs), utxosAtAddress, utxosAtPaymentCredential, stakeAddressInfo, slotConfig, slotOfCurrentBlock, logMsg #-}
 
     -- | Get the network id
     networkId :: m GYNetworkId
@@ -166,6 +166,8 @@ class MonadError GYTxMonadException m => GYTxQueryMonad m where
     utxosAtPaymentCredentialsWithDatums :: [GYPaymentCredential] -> m [(GYUTxO, Maybe GYDatum)]
     utxosAtPaymentCredentialsWithDatums = gyQueryUtxosAtPaymentCredsWithDatumsDefault utxosAtPaymentCredentials lookupDatum
 
+    stakeAddressInfo :: GYStakeAddress -> m GYStakeAddressInfo
+
     {- | Obtain the slot config for the network.
 
     Implementations using era history to create slot config may raise 'GYEraSummariesToSlotConfigError'.
@@ -212,6 +214,7 @@ instance GYTxQueryMonad m => GYTxQueryMonad (RandT g m) where
     utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc
     utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials
     utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums
+    stakeAddressInfo = lift . stakeAddressInfo
     slotConfig = lift slotConfig
     slotOfCurrentBlock = lift slotOfCurrentBlock
     logMsg ns s = lift . logMsg ns s
@@ -237,6 +240,7 @@ instance GYTxQueryMonad m => GYTxQueryMonad (ReaderT env m) where
     utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc
     utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials
     utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums
+    stakeAddressInfo = lift . stakeAddressInfo
     slotConfig = lift slotConfig
     slotOfCurrentBlock = lift slotOfCurrentBlock
     logMsg ns s = lift . logMsg ns s
@@ -262,6 +266,7 @@ instance GYTxQueryMonad m => GYTxQueryMonad (ExceptT GYTxMonadException m) where
     utxosAtPaymentCredentialWithDatums pc = lift . utxosAtPaymentCredentialWithDatums pc
     utxosAtPaymentCredentials = lift . utxosAtPaymentCredentials
     utxosAtPaymentCredentialsWithDatums = lift . utxosAtPaymentCredentialsWithDatums
+    stakeAddressInfo = lift . stakeAddressInfo
     slotConfig = lift slotConfig
     slotOfCurrentBlock = lift slotOfCurrentBlock
     logMsg ns s = lift . logMsg ns s

src/GeniusYield/TxBuilder/Node.hs

@@ -115,6 +115,9 @@ instance GYTxQueryMonad GYTxMonadNode where
     utxosAtTxOutRefsWithDatums refs = GYTxMonadNode $ \env ->
         gyQueryUtxosAtTxOutRefsWithDatums (envProviders env) refs
 
+    stakeAddressInfo stakeAddr = GYTxMonadNode $ \env ->
+        gyGetStakeAddressInfo (envProviders env) stakeAddr
+
     slotConfig = GYTxMonadNode $ \env ->
         gyGetSlotConfig (envProviders env)
 

src/GeniusYield/TxBuilder/NodeQuery.hs

@@ -117,6 +117,11 @@ instance GYTxQueryMonad GYTxQueryMonadNode where
       GYTxQueryMonadNode $ \(GYTxNodeEnv _ providers) ->
         gyQueryUtxosAtTxOutRefsWithDatums providers orefs
 
+    stakeAddressInfo saddr = do
+      logMsg mempty GYInfo $ printf "Querying Stake Address Info: %s" saddr
+      GYTxQueryMonadNode $ \(GYTxNodeEnv _ providers) ->
+        gyGetStakeAddressInfo providers saddr
+
     slotConfig = GYTxQueryMonadNode $ \(GYTxNodeEnv _ providers) ->
         gyGetSlotConfig providers
 

src/GeniusYield/TxBuilder/Run.hs

@@ -56,6 +56,7 @@ import qualified PlutusTx.Builtins.Internal                as Plutus
 
 import qualified Cardano.Simple.PlutusLedgerApi.V1.Scripts as Fork
 import           Data.Sequence                             (ViewR (..), viewr)
+import qualified Data.Text.Encoding                        as Text
 import           GeniusYield.Imports
 import           GeniusYield.Transaction                   (BuildTxException (BuildTxBalancingError),
                                                             GYCoinSelectionStrategy (GYRandomImproveMultiAsset))
@@ -213,6 +214,14 @@ instance GYTxQueryMonad GYTxMonadRun where
                 , utxoRefScript = s
                 }
 
+    stakeAddressInfo saddr = do
+        ms <- liftRun $ gets mockStake
+        let sc = stakeAddressToCredential saddr & stakeCredentialToPlutus & Plutus.StakingHash
+        pure $ GYStakeAddressInfo {
+            gyStakeAddressInfoAvailableRewards = fromInteger $ fromMaybe 0 $ lookupReward sc ms,
+            gyStakeAddressInfoDelegatedPool = Map.toList (stake'pools ms) & find (\(_pid, scs) -> sc `elem` pool'stakes scs) >>= (fst >>> unPoolId >>> pubKeyHashFromPlutus >>> rightToMaybe) >>= (pubKeyHashToApi >>> Api.serialiseToRawBytesHexText >>> Text.encodeUtf8 >>> Api.deserialiseFromRawBytesHex (Api.AsHash Api.AsStakePoolKey) >>> rightToMaybe) <&> stakePoolIdFromApi
+        }
+
     slotConfig = do
         (zero, len) <- slotConfig'
         return $ simpleSlotConfig zero len

src/GeniusYield/Types.hs

@@ -11,35 +11,37 @@ module GeniusYield.Types
     , module X
 ) where
 
-import           Numeric.Natural                  (Natural)
+import           Numeric.Natural                    (Natural)
 
-import           GeniusYield.Types.Ada            as X
-import           GeniusYield.Types.Address        as X
-import           GeniusYield.Types.Credential     as X
-import           GeniusYield.Types.Datum          as X
-import           GeniusYield.Types.Era            as X
-import           GeniusYield.Types.Key            as X
-import           GeniusYield.Types.Ledger         as X
-import           GeniusYield.Types.Logging        as X
-import           GeniusYield.Types.Natural        as X
-import           GeniusYield.Types.NetworkId      as X
-import           GeniusYield.Types.PaymentKeyHash as X
-import           GeniusYield.Types.PlutusVersion  as X
-import           GeniusYield.Types.Providers      as X
-import           GeniusYield.Types.PubKeyHash     as X
-import           GeniusYield.Types.Rational       as X
-import           GeniusYield.Types.Redeemer       as X
-import           GeniusYield.Types.Script         as X
-import           GeniusYield.Types.Slot           as X
-import           GeniusYield.Types.SlotConfig     as X
-import           GeniusYield.Types.StakeKeyHash   as X
-import           GeniusYield.Types.Time           as X
-import           GeniusYield.Types.Tx             as X
-import           GeniusYield.Types.TxBody         as X
-import           GeniusYield.Types.TxIn           as X
-import           GeniusYield.Types.TxMetadata     as X
-import           GeniusYield.Types.TxOut          as X
-import           GeniusYield.Types.TxOutRef       as X
-import           GeniusYield.Types.UTxO           as X
-import           GeniusYield.Types.Value          as X
-import           GeniusYield.Types.Wallet         as X
+import           GeniusYield.Types.Ada              as X
+import           GeniusYield.Types.Address          as X
+import           GeniusYield.Types.Credential       as X
+import           GeniusYield.Types.Datum            as X
+import           GeniusYield.Types.Era              as X
+import           GeniusYield.Types.Key              as X
+import           GeniusYield.Types.Ledger           as X
+import           GeniusYield.Types.Logging          as X
+import           GeniusYield.Types.Natural          as X
+import           GeniusYield.Types.NetworkId        as X
+import           GeniusYield.Types.PaymentKeyHash   as X
+import           GeniusYield.Types.PlutusVersion    as X
+import           GeniusYield.Types.Providers        as X
+import           GeniusYield.Types.PubKeyHash       as X
+import           GeniusYield.Types.Rational         as X
+import           GeniusYield.Types.Redeemer         as X
+import           GeniusYield.Types.Script           as X
+import           GeniusYield.Types.Slot             as X
+import           GeniusYield.Types.SlotConfig       as X
+import           GeniusYield.Types.StakeAddressInfo as X
+import           GeniusYield.Types.StakeKeyHash     as X
+import           GeniusYield.Types.StakePoolId      as X
+import           GeniusYield.Types.Time             as X
+import           GeniusYield.Types.Tx               as X
+import           GeniusYield.Types.TxBody           as X
+import           GeniusYield.Types.TxIn             as X
+import           GeniusYield.Types.TxMetadata       as X
+import           GeniusYield.Types.TxOut            as X
+import           GeniusYield.Types.TxOutRef         as X
+import           GeniusYield.Types.UTxO             as X
+import           GeniusYield.Types.Value            as X
+import           GeniusYield.Types.Wallet           as X

src/GeniusYield/Types/Credential.hs

@@ -18,6 +18,7 @@ module GeniusYield.Types.Credential (
   , GYStakeCredential (..)
   , stakeCredentialFromApi
   , stakeCredentialToApi
+  , stakeCredentialToPlutus
   , stakeCredentialToHexText
   ) where
 
@@ -30,6 +31,7 @@ import           GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash,
                                                    paymentKeyHashFromApi,
                                                    paymentKeyHashToApi,
                                                    paymentKeyHashToPlutus)
+import           GeniusYield.Types.PubKeyHash     (CanSignTx (fromPubKeyHash, toPubKeyHash))
 import           GeniusYield.Types.Script         (GYValidatorHash,
                                                    validatorHashFromApi,
                                                    validatorHashToApi,
@@ -101,6 +103,11 @@ stakeCredentialFromApi :: Api.StakeCredential -> GYStakeCredential
 stakeCredentialFromApi (Api.StakeCredentialByKey skh) = GYStakeCredentialByKey (stakeKeyHashFromApi skh)
 stakeCredentialFromApi (Api.StakeCredentialByScript sh) = GYStakeCredentialByScript (validatorHashFromApi sh)
 
+-- | Convert @GY@ type to corresponding type in @plutus@ library.
+stakeCredentialToPlutus :: GYStakeCredential -> Plutus.Credential
+stakeCredentialToPlutus (GYStakeCredentialByKey pkh) = Plutus.PubKeyCredential (paymentKeyHashToPlutus $ fromPubKeyHash $ toPubKeyHash pkh)
+stakeCredentialToPlutus (GYStakeCredentialByScript sh) = Plutus.ScriptCredential (validatorHashToPlutus sh)
+
 -- | Get hexadecimal value of stake credential.
 stakeCredentialToHexText :: GYStakeCredential -> Text
 stakeCredentialToHexText =