Merge pull request #386 from geniusyield/385-stake-pool-certs

feat(#385): stake pool related certificates

CHANGELOG.md

@@ -1,12 +1,12 @@
 ## 0.8.0
 
 * Note that there has been large internal refactoring inside this update, but these are mostly non breaking as we provide pattern & type synonyms to keep earlier behavior. In particular:
-  * We define a new type `GYKeyHash kr` and all other key hashes such as `GYPaymentKeyHash` are type synonyms around it.
+  * We define a new type `GYKeyHash kr` and all other key hashes such as `GYPaymentKeyHash`, `GYStakePoolId` are type synonyms around it.
   * We define a new type `GYCredential kr` and all other credentials such as `GYPaymentCredential` are type synonyms around it. 
   * Likewise types `GYSigningKey kr`, `GYVerificationKey kr`, `GYExtendedSigningKey kr` are newly introduced and previous relevant key types like `GYPaymentSigningKey` are simply type synonyms.
 * Constructor of `GYPubKeyHash` is no longer exported.
 * `readSomeSigningKey` is removed.
-* Adds additional certificates such as those related to governance, drep participation, etc.
+* Adds additional certificates such as those related to governance, drep participation, stake pool registration, etc.
 * Tracks node version 10.1.3 and corresponding updated CLB version.
 * Update default value of `GYAwaitTxParameters` to now have 100 max attempts.
 

atlas-cardano.cabal

@@ -147,6 +147,7 @@ library
     GeniusYield.Types.OpenApi
     GeniusYield.Types.PaymentKeyHash
     GeniusYield.Types.PlutusVersion
+    GeniusYield.Types.Pool
     GeniusYield.Types.ProtocolParameters
     GeniusYield.Types.Providers
     GeniusYield.Types.PubKeyHash
@@ -208,6 +209,7 @@ library
     http-client-tls ^>=0.3.6,
     http-types ^>=0.12.4,
     indexed-traversable ^>=0.1.4,
+    iproute ^>=1.7.14,
     katip ^>=0.8.8,
     lens ^>=5.2.3,
     MonadRandom ^>=0.6,
@@ -372,6 +374,7 @@ test-suite atlas-privnet-tests
     GeniusYield.Test.Privnet.Stake.Key
     GeniusYield.Test.Privnet.Stake.Utils
     GeniusYield.Test.Privnet.Stake.Validator
+    GeniusYield.Test.Privnet.StakePool
 
   -- Dependencies inherited from the library. No need to specify bounds.
   build-depends:

src/GeniusYield/Test/Privnet/Examples/Gift.hs

@@ -11,7 +11,6 @@ Stability   : develop
 module GeniusYield.Test.Privnet.Examples.Gift (tests) where
 
 import Cardano.Api qualified as Api
-import Cardano.Ledger.Alonzo.PParams (ppCollateralPercentageL)
 import Control.Applicative ((<|>))
 import Control.Concurrent (threadDelay)
 import Control.Lens ((.~), (^.))

src/GeniusYield/Transaction.hs

@@ -69,7 +69,6 @@ import Cardano.Crypto.DSIGN (
   sizeSigDSIGN,
   sizeVerKeyDSIGN,
  )
-import Cardano.Ledger.Alonzo.PParams (ppCollateralPercentageL)
 import Cardano.Ledger.Alonzo.PParams qualified as Ledger
 import Cardano.Ledger.Alonzo.Scripts qualified as AlonzoScripts
 import Cardano.Ledger.Alonzo.Tx qualified as AlonzoTx
@@ -268,6 +267,7 @@ balanceTxStep
     , gyBTxEnvOwnUtxos = ownUtxos
     , gyBTxEnvChangeAddr = changeAddr
     , gyBTxEnvCollateral = collateral
+    , gyBTxEnvPools = pools
     }
   mmint
   wdrls
@@ -297,12 +297,22 @@ balanceTxStep
             )
             (0, 0)
             certs
+        ppDeposit :: Natural = pp ^. Ledger.ppPoolDepositL & fromIntegral
+        spRegsAmt :: Natural =
+          foldl'
+            ( \(!accRegsAmt) (gyTxCertCertificate' -> cert) -> case cert of
+                GYStakePoolRegistrationCertificate poolParams -> (if Set.member (stakePoolIdToApi (poolId poolParams)) pools then accRegsAmt else accRegsAmt + ppDeposit)
+                -- Retirement does not add ADA source.
+                _ -> accRegsAmt
+            )
+            0
+            certs
         -- Extra ada is received from withdrawals and stake credential deregistration.
         adaSource =
           let wdrlsAda = getSum $ foldMap' (coerce . gyTxWdrlAmount) wdrls
            in wdrlsAda + stakeCredDeregsAmt + drepDeregsAmt
         -- Ada lost due to stake credential registration.
-        adaSink = stakeCredRegsAmt + drepRegsAmt
+        adaSink = stakeCredRegsAmt + drepRegsAmt + spRegsAmt
         collaterals
           | needsCollateral = utxosFromUTxO collateral
           | otherwise = mempty

src/GeniusYield/TxBuilder/Class.hs

@@ -130,6 +130,7 @@ import GeniusYield.TxBuilder.Query.Class
 import GeniusYield.TxBuilder.User
 import GeniusYield.Types
 import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey)
+import GeniusYield.Types.TxCert.Internal (GYTxCert (..))
 import PlutusLedgerApi.V1 qualified as Plutus (
   Address,
   DatumHash,
@@ -960,7 +961,14 @@ buildTxBodyCore ownUtxoUpdateF cstrat skeletons = do
   ss <- systemStart
   eh <- eraHistory
   pp <- protocolParams
-  let ps = mempty -- This denotes the set of registered stake pools that are being unregistered in current transaction. We don't support this yet.
+  let isRegPool = any (any (\(GYTxCert pb _) -> case pb of GYStakePoolRegistrationCertificatePB _ -> True; _anyOther -> False) . gytxCerts) skeletons
+  ps <-
+    if isRegPool
+      then
+        stakePools
+      else
+        -- We just add for retiring pools.
+        pure $ foldl' (\acc (GYTxCert pb _) -> case pb of GYStakePoolRetirementCertificatePB spid _ -> Set.insert (stakePoolIdToApi spid) acc; _anyOther -> acc) Set.empty $ concatMap gytxCerts skeletons
   collateral <- ownCollateral
   addrs <- ownAddresses
   change <- ownChangeAddress

src/GeniusYield/TxBuilder/Common.hs

@@ -20,7 +20,6 @@ module GeniusYield.TxBuilder.Common (
 ) where
 
 import Cardano.Api qualified as Api
-import Cardano.Api.Ledger (unboundRational)
 import Cardano.Api.Ledger qualified as Ledger
 import Cardano.Api.Shelley qualified as Api.S
 import Cardano.Ledger.Alonzo.Core qualified as Ledger

src/GeniusYield/Types.hs

@@ -8,8 +8,156 @@ Stability   : develop
 module GeniusYield.Types (
   Natural,
   module X,
+
+  -- * Shelley params
+
+  -- | Protocol parameters introduced in Shelley era
+
+  -- ** @MinFeeA@
+
+  -- | Min fee factor
+  ppMinFeeAL,
+
+  -- ** @MinFeeB@
+
+  -- | Min fee constant
+  ppMinFeeBL,
+
+  -- ** @MaxBBSize@
+
+  -- | Max block body size
+  ppMaxBBSizeL,
+
+  -- ** @AaxBHSize@
+
+  -- | Max block header size
+  ppMaxBHSizeL,
+
+  -- ** @PoolDeposit@
+
+  -- | Stake pool deposit
+  ppPoolDepositL,
+
+  -- ** @EMax@
+
+  -- | Epoch bound on pool retirement
+  ppEMaxL,
+
+  -- ** @NOpt@
+
+  -- | Desired number of pools
+  ppNOptL,
+
+  -- ** @A0@
+
+  -- | Pool influence
+  ppA0L,
+
+  -- ** @Tau@
+
+  -- | Treasury expansion
+  ppTauL,
+
+  -- ** @Rho@
+
+  -- | Monetary expansion
+  ppRhoL,
+
+  -- ** @ProtocolVersion@
+
+  -- | Protocol version
+  ppProtocolVersionL,
+
+  -- ** @MinUTxOValue@
+
+  -- | Minimum allowed value of a new TxOut
+  ppMinUTxOValueL,
+
+  -- ** @MinPoolCast@
+
+  -- | Miminum allowed stake pool cost
+  ppMinPoolCostL,
+
+  -- ** @KeyDeposit@
+  ppKeyDepositL,
+
+  -- ** @MaxTxSize@
+  ppMaxTxSizeL,
+
+  -- * Alonzo params
+
+  -- ** @CostModels@
+  ppCostModelsL,
+
+  -- ** @Prices@
+  ppPricesL,
+
+  -- ** @MaxTxExUnits@
+
+  -- | Limit the total per-transaction resource use for phase-2 scripts.
+  ppMaxTxExUnitsL,
+
+  -- ** @MaxBlockExUnits@
+
+  -- | Limit the total per-transaction and per-block resource use for phase-2 scripts.
+  ppMaxBlockExUnitsL,
+
+  -- ** @MaxValSize@
+
+  -- | The new parameter maxValSize replaces the constant @maxValSize@ used Mary era to
+  -- limit the size of the Value part of an output in a serialised transaction.
+  ppMaxValSizeL,
+
+  -- ** @CollateralPercentage@
+
+  -- | The parameter collateralPercent is used to specify the percentage of the total
+  -- transaction fee its collateral must (at minimum) cover.
+  ppCollateralPercentageL,
+
+  -- ** @MaxCollateralInputs@
+
+  -- | The parameter @maxCollateralInputs@ is used to limit, additionally, the total number
+  -- of collateral inputs, and thus the total number of additional signatures that must be
+  -- checked during validation.
+  ppMaxCollateralInputsL,
+
+  -- * Babbage params
+
+  -- | Protocol parameters introduced in Babbage era
+
+  -- ** @CoinsPerUTxOByte@
+
+  -- | Cost in the amount of lovelace ber byte.
+  CoinPerByte (..),
+  ppCoinsPerUTxOByteL,
 ) where
 
+import Cardano.Ledger.Api (
+  CoinPerByte (..),
+  ppA0L,
+  ppCoinsPerUTxOByteL,
+  ppCollateralPercentageL,
+  ppCostModelsL,
+  ppEMaxL,
+  ppKeyDepositL,
+  ppMaxBBSizeL,
+  ppMaxBHSizeL,
+  ppMaxBlockExUnitsL,
+  ppMaxCollateralInputsL,
+  ppMaxTxExUnitsL,
+  ppMaxTxSizeL,
+  ppMaxValSizeL,
+  ppMinFeeAL,
+  ppMinFeeBL,
+  ppMinPoolCostL,
+  ppMinUTxOValueL,
+  ppNOptL,
+  ppPoolDepositL,
+  ppPricesL,
+  ppProtocolVersionL,
+  ppRhoL,
+  ppTauL,
+ )
 import GeniusYield.Types.Ada as X
 import GeniusYield.Types.Address as X
 import GeniusYield.Types.Anchor as X
@@ -31,6 +179,7 @@ import GeniusYield.Types.NetworkId as X
 import GeniusYield.Types.OpenApi as X
 import GeniusYield.Types.PaymentKeyHash as X
 import GeniusYield.Types.PlutusVersion as X
+import GeniusYield.Types.Pool as X
 import GeniusYield.Types.Providers as X
 import GeniusYield.Types.PubKeyHash as X
 import GeniusYield.Types.Rational as X

src/GeniusYield/Types/Anchor.hs

@@ -10,9 +10,13 @@ module GeniusYield.Types.Anchor (
   textToUrl,
   unsafeTextToUrl,
   urlToText,
+  urlToLedger,
+  urlFromLedger,
   GYAnchorData,
   GYAnchorDataHash,
   hashAnchorData,
+  anchorDataHashToByteString,
+  anchorDataHashFromByteString,
   GYAnchor (..),
   anchorToLedger,
   anchorFromLedger,
@@ -21,9 +25,17 @@ module GeniusYield.Types.Anchor (
 import GeniusYield.Imports
 
 import Cardano.Api.Ledger qualified as Ledger
+import Cardano.Crypto.Hash.Class qualified as Crypto
+import Cardano.Ledger.SafeHash qualified as Ledger
 import Control.Monad ((>=>))
 import Data.ByteString.Char8 (ByteString)
 
+{- $setup
+
+>>> :set -XOverloadedStrings -XTypeApplications -XDataKinds
+>>> import qualified Data.ByteString.Base16 as BS16
+-}
+
 {- | URL to a JSON payload of metadata. Note that we require URL to be at most 128 bytes.
 >>> textToUrl "https://geniusyield.co"
 GYUrl (Url {urlToText = "https://geniusyield.co"})
@@ -43,6 +55,12 @@ unsafeTextToUrl t = fromMaybe (error "textToUrl: failed") $ textToUrl t
 urlToText :: GYUrl -> Text
 urlToText = Ledger.urlToText . coerce
 
+urlToLedger :: GYUrl -> Ledger.Url
+urlToLedger = coerce
+
+urlFromLedger :: Ledger.Url -> GYUrl
+urlFromLedger = coerce
+
 -- | Anchor data.
 type GYAnchorData = ByteString
 
@@ -54,6 +72,24 @@ newtype GYAnchorDataHash = GYAnchorDataHash (Ledger.SafeHash Ledger.StandardCryp
   deriving stock Show
   deriving newtype (Eq, Ord)
 
+{- | Convert a 'GYAnchorDataHash' to a 'ByteString'.
+>>> let h = hashAnchorData "Hello, World!"
+
+>>> show h
+"GYAnchorDataHash (SafeHash \"511bc81dde11180838c562c82bb35f3223f46061ebde4a955c27b3f489cf1e03\")"
+
+>>> BS16.encode $ anchorDataHashToByteString h
+"511bc81dde11180838c562c82bb35f3223f46061ebde4a955c27b3f489cf1e03"
+
+>>> anchorDataHashFromByteString $ anchorDataHashToByteString h
+Just (GYAnchorDataHash (SafeHash "511bc81dde11180838c562c82bb35f3223f46061ebde4a955c27b3f489cf1e03"))
+-}
+anchorDataHashToByteString :: GYAnchorDataHash -> ByteString
+anchorDataHashToByteString (GYAnchorDataHash l) = Ledger.originalBytes l
+
+anchorDataHashFromByteString :: ByteString -> Maybe GYAnchorDataHash
+anchorDataHashFromByteString bs = GYAnchorDataHash . Ledger.unsafeMakeSafeHash <$> Crypto.hashFromBytes bs
+
 -- | Hash anchor data.
 hashAnchorData :: GYAnchorData -> GYAnchorDataHash
 hashAnchorData = GYAnchorDataHash . Ledger.hashAnchorData . Ledger.AnchorData