From c50a6f822477a05150d271bbe4c180d7d8f797eb Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Sun, 12 Jan 2025 18:23:19 +0530 Subject: [PATCH 01/14] feat: governance voting procedures wip, refactor transaction build scripts & witnesses --- CHANGELOG.md | 2 + atlas-cardano.cabal | 4 + src/GeniusYield/Providers/Blockfrost.hs | 1 - src/GeniusYield/Providers/Maestro.hs | 1 - src/GeniusYield/Providers/Node.hs | 1 - src/GeniusYield/Transaction.hs | 43 ++++- src/GeniusYield/Transaction/Common.hs | 5 +- src/GeniusYield/TxBuilder/Class.hs | 7 +- src/GeniusYield/TxBuilder/Common.hs | 23 ++- src/GeniusYield/TxBuilder/Query/Class.hs | 1 - src/GeniusYield/TxBuilder/User.hs | 1 - src/GeniusYield/Types.hs | 4 + src/GeniusYield/Types/BuildScript.hs | 166 ++++++++++++++++++ src/GeniusYield/Types/BuildWitness.hs | 50 ++++++ src/GeniusYield/Types/Governance.hs | 116 ++++++++++++ src/GeniusYield/Types/Key.hs | 2 + src/GeniusYield/Types/Script.hs | 101 +---------- src/GeniusYield/Types/TxCert.hs | 4 +- src/GeniusYield/Types/TxCert/Internal.hs | 36 ++-- src/GeniusYield/Types/TxIn.hs | 59 +++---- src/GeniusYield/Types/TxWdrl.hs | 34 ++-- src/GeniusYield/Types/Value.hs | 3 +- .../GeniusYield/Test/Privnet/Committee.hs | 4 - tests/GeniusYield/Test/GYTxSkeleton.hs | 2 +- 24 files changed, 469 insertions(+), 201 deletions(-) create mode 100644 src/GeniusYield/Types/BuildScript.hs create mode 100644 src/GeniusYield/Types/BuildWitness.hs create mode 100644 src/GeniusYield/Types/Governance.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 91bceb70..f315d8e1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,8 @@ * 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. +* `GYInScript` and `GYStakeValScript` are now defined as a type synonyms around `GYBuildPlutusScript` whereas `GYMintScript` is a type synonym around `GYBuildScript` which now also includes simple scripts (besides plutus scripts). Pattern synonyms are provided for backwards compatibility. These and related functions such as `stakeValidatorVersionFromWitness`, `gyStakeValScriptToSerialisedScript` are now exported from `GeniusYield.Types.BuildScript` instead of `GeniusYield.Types.Script`. +* `GYTxWdrlWitness`, `GYTxCertWitness` are now defined as a type synonyms around generic `GYTxBuildWitness` and now also includes simple scripts. Pattern synonyms are provided to maintain backwards compatibility. ## 0.7.0 diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 0845c5e7..b44daf74 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -36,6 +36,7 @@ common common LambdaCase MultiWayIf OverloadedStrings + PatternSynonyms RecordWildCards RoleAnnotations TypeFamilyDependencies @@ -129,6 +130,8 @@ library GeniusYield.Types.Blueprint.Schema GeniusYield.Types.Blueprint.TH GeniusYield.Types.Blueprint.Validator + GeniusYield.Types.BuildScript + GeniusYield.Types.BuildWitness GeniusYield.Types.Certificate GeniusYield.Types.Credential GeniusYield.Types.Datum @@ -136,6 +139,7 @@ library GeniusYield.Types.DRep GeniusYield.Types.Epoch GeniusYield.Types.Era + GeniusYield.Types.Governance GeniusYield.Types.KeyHash GeniusYield.Types.Key GeniusYield.Types.Key.Class diff --git a/src/GeniusYield/Providers/Blockfrost.hs b/src/GeniusYield/Providers/Blockfrost.hs index 3a7718eb..104e9ed8 100644 --- a/src/GeniusYield/Providers/Blockfrost.hs +++ b/src/GeniusYield/Providers/Blockfrost.hs @@ -44,7 +44,6 @@ import Data.Time.Clock.POSIX qualified as Time import GeniusYield.Imports import GeniusYield.Providers.Common import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import GeniusYield.Utils (serialiseToBech32WithPrefix) import Money qualified import Ouroboros.Consensus.HardFork.History (EraParams (eraGenesisWin)) diff --git a/src/GeniusYield/Providers/Maestro.hs b/src/GeniusYield/Providers/Maestro.hs index 147b9829..03b5995d 100644 --- a/src/GeniusYield/Providers/Maestro.hs +++ b/src/GeniusYield/Providers/Maestro.hs @@ -50,7 +50,6 @@ import GHC.Natural (wordToNatural) import GeniusYield.Imports import GeniusYield.Providers.Common import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import Maestro.Client.V1 qualified as Maestro import Maestro.Client.V1.Accounts qualified as Maestro import Maestro.Types.V1 qualified as Maestro diff --git a/src/GeniusYield/Providers/Node.hs b/src/GeniusYield/Providers/Node.hs index b8353b64..3693e00c 100644 --- a/src/GeniusYield/Providers/Node.hs +++ b/src/GeniusYield/Providers/Node.hs @@ -32,7 +32,6 @@ import Data.Text qualified as Txt import GeniusYield.CardanoApi.Query import GeniusYield.Providers.Common (SubmitTxException (SubmitTxException), makeLastEraEndUnbounded) import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) ------------------------------------------------------------------------------- diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index c2a15734..4197bcb3 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -104,7 +104,6 @@ import GeniusYield.Transaction.CBOR import GeniusYield.Transaction.CoinSelection import GeniusYield.Transaction.Common import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import GeniusYield.Types.TxCert.Internal -- | A container for various network parameters, and user wallet information, used by balancer. @@ -150,7 +149,7 @@ buildUnsignedTxBody :: -- | reference inputs GYUTxOs -> -- | minted values - Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -> + Maybe (GYValue, [(GYBuildScript v, GYRedeemer)]) -> -- | withdrawals [GYTxWdrl v] -> -- | certificates @@ -159,8 +158,9 @@ buildUnsignedTxBody :: Maybe GYSlot -> Set GYPubKeyHash -> Maybe GYTxMetadata -> + GYTxVotingProcedures v -> m (Either GYBuildTxError GYTxBody) -buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata = buildTxLoop cstrat extraLovelaceStart +buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata vps = buildTxLoop cstrat extraLovelaceStart where certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs @@ -226,6 +226,7 @@ buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub sig , gybtxSigners = signers , gybtxRefIns = refIns , gybtxMetadata = mbTxMetadata + , gybtxVotingProcedures = vps } (length outsOld) @@ -374,6 +375,7 @@ finalizeGYBalancedTx , gybtxSigners = signers , gybtxRefIns = utxosRefInputs , gybtxMetadata = mbTxMetadata + , gybtxVotingProcedures = vps } = makeTransactionBodyAutoBalanceWrapper collaterals @@ -477,10 +479,13 @@ finalizeGYBalancedTx Api.BuildTxWith $ Map.fromList [ ( mintingPolicyApiIdFromWitness p - , gyMintingScriptWitnessToApiPlutusSW - p - (redeemerToApi r) - (Api.ExecutionUnits 0 0) + , case p of + GYBuildPlutusScript s -> + gyMintingScriptWitnessToApiPlutusSW + s + (redeemerToApi r) + (Api.ExecutionUnits 0 0) + GYBuildSimpleScript s -> simpleScriptWitnessToApi s ) | (p, r) <- xs ] @@ -530,6 +535,26 @@ finalizeGYBalancedTx unregisteredDRepCredsMap = Map.fromList [(credentialToLedger sc, fromIntegral amt) | GYDRepUnregistrationCertificate sc amt <- map gyTxCertCertificate' certs] + vps' = + if vps == mempty + then Nothing + else + let vpsApi = + Api.TxVotingProcedures (votingProceduresToLedger (Map.map snd vps)) $ + Api.BuildTxWith + ( Map.map fst vps + -- https://github.com/IntersectMBO/cardano-api/issues/722. + & Map.filter + ( \case + GYTxBuildWitnessKey -> False + GYTxBuildWitnessPlutusScript _ _ -> True + GYTxBuildWitnessSimpleScript _ -> True + ) + & Map.mapKeys voterToLedger + & Map.map unsafeBuildScriptWitnessToApi + ) + in Just vpsApi >>= Api.mkFeatured + body :: Api.TxBodyContent Api.BuildTx ApiEra body = Api.TxBodyContent @@ -554,9 +579,9 @@ finalizeGYBalancedTx , Api.txMintValue = mint , Api.txScriptValidity = Api.TxScriptValidityNone , Api.txProposalProcedures = Nothing - , Api.txVotingProcedures = Nothing + , Api.txVotingProcedures = vps' , Api.txCurrentTreasuryValue = Nothing -- FIXME:? - , Api.txTreasuryDonation = Nothing + , Api.txTreasuryDonation = Nothing -- FIXME:? } {- | Wraps around 'Api.makeTransactionBodyAutoBalance' just to verify the final ex units and tx size are within limits. diff --git a/src/GeniusYield/Transaction/Common.hs b/src/GeniusYield/Transaction/Common.hs index 1e54fea2..30253fd5 100644 --- a/src/GeniusYield/Transaction/Common.hs +++ b/src/GeniusYield/Transaction/Common.hs @@ -22,7 +22,9 @@ import Cardano.Ledger.Coin qualified as Ledger import GeniusYield.Imports import GeniusYield.Transaction.CBOR import GeniusYield.Types.Address +import GeniusYield.Types.BuildScript import GeniusYield.Types.Era +import GeniusYield.Types.Governance (GYTxVotingProcedures) import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import GeniusYield.Types.PubKeyHash import GeniusYield.Types.Redeemer @@ -46,7 +48,7 @@ data GYBalancedTx v = GYBalancedTx { gybtxIns :: ![GYTxInDetailed v] , gybtxCollaterals :: !GYUTxOs , gybtxOuts :: ![GYTxOut v] - , gybtxMint :: !(Maybe (GYValue, [(GYMintScript v, GYRedeemer)])) + , gybtxMint :: !(Maybe (GYValue, [(GYBuildScript v, GYRedeemer)])) , gybtxWdrls :: ![GYTxWdrl v] , gybtxCerts :: ![GYTxCert' v] , gybtxInvalidBefore :: !(Maybe GYSlot) @@ -54,6 +56,7 @@ data GYBalancedTx v = GYBalancedTx , gybtxSigners :: !(Set GYPubKeyHash) , gybtxRefIns :: !GYUTxOs , gybtxMetadata :: !(Maybe GYTxMetadata) + , gybtxVotingProcedures :: !(GYTxVotingProcedures v) } -- | A further detailed version of 'GYTxIn', containing all information about a UTxO. diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index 63673e7f..84f7cdb6 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -85,6 +85,7 @@ module GeniusYield.TxBuilder.Class ( mustHaveOutput, mustHaveOptionalOutput, mustHaveTxMetadata, + mustHaveVotingProcedures, mustMint, mustHaveWithdrawal, mustHaveCertificate, @@ -129,7 +130,6 @@ import GeniusYield.TxBuilder.Errors 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, @@ -818,7 +818,10 @@ mustHaveOptionalOutput = maybe mempty $ \o -> emptyGYTxSkeleton {gytxOuts = [o]} mustHaveTxMetadata :: Maybe GYTxMetadata -> GYTxSkeleton v mustHaveTxMetadata m = emptyGYTxSkeleton {gytxMetadata = m} -mustMint :: GYMintScript v -> GYRedeemer -> GYTokenName -> Integer -> GYTxSkeleton v +mustHaveVotingProcedures :: VersionIsGreaterOrEqual v 'PlutusV3 => GYTxVotingProcedures v -> GYTxSkeleton v +mustHaveVotingProcedures vp = emptyGYTxSkeleton {gytxVotingProcedures = GYTxSkeletonVotingProcedures vp} + +mustMint :: GYBuildScript v -> GYRedeemer -> GYTokenName -> Integer -> GYTxSkeleton v mustMint _ _ _ 0 = mempty mustMint p r tn n = emptyGYTxSkeleton {gytxMint = Map.singleton p (Map.singleton tn n, r)} diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 298a958d..75706a7b 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -8,6 +8,7 @@ Stability : develop module GeniusYield.TxBuilder.Common ( GYTxSkeleton (..), GYTxSkeletonRefIns (..), + GYTxSkeletonVotingProcedures (..), emptyGYTxSkeleton, gyTxSkeletonRefInsToList, gyTxSkeletonRefInsSet, @@ -44,7 +45,6 @@ import GeniusYield.Transaction.Common ( import GeniusYield.TxBuilder.Errors import GeniusYield.TxBuilder.Query.Class import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) ------------------------------------------------------------------------------- -- Transaction skeleton @@ -61,16 +61,30 @@ data GYTxSkeleton (v :: PlutusVersion) = GYTxSkeleton { gytxIns :: ![GYTxIn v] , gytxOuts :: ![GYTxOut v] , gytxRefIns :: !(GYTxSkeletonRefIns v) - , gytxMint :: !(Map (GYMintScript v) (Map GYTokenName Integer, GYRedeemer)) + , gytxMint :: !(Map (GYBuildScript v) (Map GYTokenName Integer, GYRedeemer)) , gytxWdrls :: ![GYTxWdrl v] , gytxSigs :: !(Set GYPubKeyHash) , gytxCerts :: ![GYTxCert v] , gytxInvalidBefore :: !(Maybe GYSlot) , gytxInvalidAfter :: !(Maybe GYSlot) , gytxMetadata :: !(Maybe GYTxMetadata) + , gytxVotingProcedures :: !(GYTxSkeletonVotingProcedures v) } deriving Show +data GYTxSkeletonVotingProcedures :: PlutusVersion -> Type where + GYTxSkeletonVotingProceduresNone :: GYTxSkeletonVotingProcedures v + GYTxSkeletonVotingProcedures :: VersionIsGreaterOrEqual v 'PlutusV3 => !(GYTxVotingProcedures v) -> GYTxSkeletonVotingProcedures v + +deriving instance Show (GYTxSkeletonVotingProcedures v) +deriving instance Eq (GYTxSkeletonVotingProcedures v) + +instance Semigroup (GYTxSkeletonVotingProcedures v) where + GYTxSkeletonVotingProcedures a <> GYTxSkeletonVotingProcedures b = GYTxSkeletonVotingProcedures (combineTxVotingProcedures a b) + GYTxSkeletonVotingProcedures a <> GYTxSkeletonVotingProceduresNone = GYTxSkeletonVotingProcedures a + GYTxSkeletonVotingProceduresNone <> GYTxSkeletonVotingProcedures b = GYTxSkeletonVotingProcedures b + GYTxSkeletonVotingProceduresNone <> GYTxSkeletonVotingProceduresNone = GYTxSkeletonVotingProceduresNone + data GYTxSkeletonRefIns :: PlutusVersion -> Type where GYTxSkeletonRefIns :: VersionIsGreaterOrEqual v 'PlutusV2 => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v GYTxSkeletonNoRefIns :: GYTxSkeletonRefIns v @@ -104,6 +118,7 @@ emptyGYTxSkeleton = , gytxInvalidBefore = Nothing , gytxInvalidAfter = Nothing , gytxMetadata = Nothing + , gytxVotingProcedures = GYTxSkeletonVotingProceduresNone } instance Semigroup (GYTxSkeleton v) where @@ -119,6 +134,7 @@ instance Semigroup (GYTxSkeleton v) where , gytxInvalidBefore = combineInvalidBefore (gytxInvalidBefore x) (gytxInvalidBefore y) , gytxInvalidAfter = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y) , gytxMetadata = gytxMetadata x <> gytxMetadata y + , gytxVotingProcedures = gytxVotingProcedures x <> gytxVotingProcedures y } where -- we keep only one input per utxo to spend @@ -279,6 +295,7 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk gytxInvalidAfter gytxSigs gytxMetadata + (case gytxVotingProcedures of GYTxSkeletonVotingProceduresNone -> mempty; GYTxSkeletonVotingProcedures vp -> vp) go :: GYUTxOs -> GYTxBuildResult -> [GYTxSkeleton v] -> m (Either GYBuildTxError GYTxBuildResult) go _ acc [] = pure $ Right $ reverseResult acc @@ -301,7 +318,7 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk In case of insufficient funds failure ('Left' argument): We return either 'GYTxBuildFailure' or 'GYTxBuildPartialSuccess' - Depending on whether or not any previous transactions were built succesfully. + Depending on whether or not any previous transactions were built successfully. In case of successful build: We save the newly built tx body into the existing ones (if any) diff --git a/src/GeniusYield/TxBuilder/Query/Class.hs b/src/GeniusYield/TxBuilder/Query/Class.hs index f579853a..8f9699c0 100644 --- a/src/GeniusYield/TxBuilder/Query/Class.hs +++ b/src/GeniusYield/TxBuilder/Query/Class.hs @@ -25,7 +25,6 @@ import Data.Set qualified as Set import GeniusYield.Imports import GeniusYield.TxBuilder.Errors import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) ------------------------------------------------------------------------------- -- Class diff --git a/src/GeniusYield/TxBuilder/User.hs b/src/GeniusYield/TxBuilder/User.hs index 2c48b244..56697eae 100644 --- a/src/GeniusYield/TxBuilder/User.hs +++ b/src/GeniusYield/TxBuilder/User.hs @@ -23,7 +23,6 @@ import Data.List.NonEmpty qualified as NE import GeniusYield.Imports import GeniusYield.Types.Address (GYAddress) import GeniusYield.Types.Key -import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey (toShelleyWitnessSigningKey)) import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash) import GeniusYield.Types.PubKeyHash (AsPubKeyHash (toPubKeyHash), GYPubKeyHash) import GeniusYield.Types.StakeKeyHash (GYStakeKeyHash) diff --git a/src/GeniusYield/Types.hs b/src/GeniusYield/Types.hs index 9e962445..0015300c 100644 --- a/src/GeniusYield/Types.hs +++ b/src/GeniusYield/Types.hs @@ -162,6 +162,8 @@ import GeniusYield.Types.Ada as X import GeniusYield.Types.Address as X import GeniusYield.Types.Anchor as X import GeniusYield.Types.Blueprint as X +import GeniusYield.Types.BuildScript as X +import GeniusYield.Types.BuildWitness as X import GeniusYield.Types.Certificate as X import GeniusYield.Types.Credential as X import GeniusYield.Types.DRep as X @@ -169,6 +171,7 @@ import GeniusYield.Types.Datum as X import GeniusYield.Types.Delegatee as X import GeniusYield.Types.Epoch as X import GeniusYield.Types.Era as X +import GeniusYield.Types.Governance as X import GeniusYield.Types.Key as X import GeniusYield.Types.KeyHash as X import GeniusYield.Types.KeyRole as X @@ -180,6 +183,7 @@ 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.ProtocolParameters as X import GeniusYield.Types.Providers as X import GeniusYield.Types.PubKeyHash as X import GeniusYield.Types.Rational as X diff --git a/src/GeniusYield/Types/BuildScript.hs b/src/GeniusYield/Types/BuildScript.hs new file mode 100644 index 00000000..9fc59a1f --- /dev/null +++ b/src/GeniusYield/Types/BuildScript.hs @@ -0,0 +1,166 @@ +{- | +Module : GeniusYield.Types.BuildScript +Copyright : (c) 2025 GYELD GMBH +License : Apache 2.0 +Maintainer : support@geniusyield.co +Stability : develop +-} +module GeniusYield.Types.BuildScript ( + GYBuildScript (..), + GYBuildPlutusScript (..), + GYBuildSimpleScript (..), + buildPlutusScriptVersion, + simpleScriptWitnessToApi, + + -- * Witness for stake validator (deprecated in favour of 'GYBuildPlutusScript') + GYStakeValScript, + pattern GYStakeValScript, + pattern GYStakeValReference, + gyStakeValScriptToSerialisedScript, + gyStakeValScriptWitnessToApiPlutusSW, + stakeValidatorVersionFromWitness, + + -- * Witness for minting policy (deprecated in favour of 'GYBuildScript') + GYMintScript, + pattern GYMintScript, + pattern GYMintReference, + gyMintingScriptWitnessToApiPlutusSW, + mintingPolicyIdFromWitness, + mintingPolicyApiIdFromWitness, +) where + +import Cardano.Api qualified as Api +import Cardano.Api.Script qualified as Api +import Cardano.Api.Shelley qualified as Api.S +import Data.GADT.Compare +import GeniusYield.Imports +import GeniusYield.Types.Era +import GeniusYield.Types.PlutusVersion +import GeniusYield.Types.Script +import GeniusYield.Types.TxOutRef +import PlutusLedgerApi.Common qualified as Plutus + +data GYBuildScript (u :: PlutusVersion) where + GYBuildPlutusScript :: GYBuildPlutusScript u -> GYBuildScript u + GYBuildSimpleScript :: GYBuildSimpleScript u -> GYBuildScript u + +deriving instance Show (GYBuildScript v) + +instance Eq (GYBuildScript v) where + GYBuildPlutusScript script1 == GYBuildPlutusScript script2 = script1 == script2 + GYBuildSimpleScript script1 == GYBuildSimpleScript script2 = script1 == script2 + _ == _ = False + +deriving instance Ord (GYBuildScript v) + +data GYBuildPlutusScript (u :: PlutusVersion) where + -- | 'VersionIsGreaterOrEqual' restricts which version validators can be used in this transaction. + GYBuildPlutusScriptInlined :: forall u v. v `VersionIsGreaterOrEqual` u => GYScript v -> GYBuildPlutusScript u + -- | Reference inputs can be only used in V2 transactions. + GYBuildPlutusScriptReference :: forall v. v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYBuildPlutusScript v + +deriving instance Show (GYBuildPlutusScript v) + +instance Eq (GYBuildPlutusScript v) where + GYBuildPlutusScriptReference ref1 script1 == GYBuildPlutusScriptReference ref2 script2 = ref1 == ref2 && script1 == script2 + GYBuildPlutusScriptInlined v1 == GYBuildPlutusScriptInlined v2 = defaultEq v1 v2 + _ == _ = False + +instance Ord (GYBuildPlutusScript v) where + GYBuildPlutusScriptReference r s `compare` GYBuildPlutusScriptReference r' s' = compare r r' <> compare s s' + GYBuildPlutusScriptReference _ _ `compare` _ = LT + GYBuildPlutusScriptInlined p `compare` GYBuildPlutusScriptInlined p' = defaultCompare p p' + GYBuildPlutusScriptInlined _ `compare` _ = GT + +-- | Returns the 'PlutusVersion' of the given 'GYBuildPlutusScript'. +buildPlutusScriptVersion :: GYBuildPlutusScript v -> PlutusVersion +buildPlutusScriptVersion (GYBuildPlutusScriptReference _ s) = case scriptVersion s of + SingPlutusV3 -> PlutusV3 + SingPlutusV2 -> PlutusV2 +buildPlutusScriptVersion (GYBuildPlutusScriptInlined v) = case validatorVersion v of + SingPlutusV3 -> PlutusV3 + SingPlutusV2 -> PlutusV2 + SingPlutusV1 -> PlutusV1 + +data GYBuildSimpleScript (u :: PlutusVersion) where + GYBuildSimpleScriptInlined :: !GYSimpleScript -> GYBuildSimpleScript u + GYBuildSimpleScriptReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !GYSimpleScript -> GYBuildSimpleScript v + +deriving instance Show (GYBuildSimpleScript v) + +instance Eq (GYBuildSimpleScript v) where + GYBuildSimpleScriptInlined s1 == GYBuildSimpleScriptInlined s2 = s1 == s2 + GYBuildSimpleScriptReference ref1 s1 == GYBuildSimpleScriptReference ref2 s2 = ref1 == ref2 && s1 == s2 + _ == _ = False + +instance Ord (GYBuildSimpleScript v) where + GYBuildSimpleScriptReference r s `compare` GYBuildSimpleScriptReference r' s' = compare r r' <> compare s s' + GYBuildSimpleScriptReference _ _ `compare` _ = LT + GYBuildSimpleScriptInlined p `compare` GYBuildSimpleScriptInlined p' = compare p p' + GYBuildSimpleScriptInlined _ `compare` _ = GT + +simpleScriptWitnessToApi :: GYBuildSimpleScript u -> Api.S.ScriptWitness witctx Api.S.ConwayEra +simpleScriptWitnessToApi = Api.SimpleScriptWitness Api.SimpleScriptInConway . h + where + h :: GYBuildSimpleScript u -> Api.S.SimpleScriptOrReferenceInput lang + h (GYBuildSimpleScriptInlined v) = Api.SScript $ simpleScriptToApi v + h (GYBuildSimpleScriptReference ref s) = Api.SReferenceScript (txOutRefToApi ref) $ Just $ hashSimpleScript' s + +type GYStakeValScript v = GYBuildPlutusScript v + +pattern GYStakeValScript :: () => VersionIsGreaterOrEqual v u => GYScript v -> GYBuildPlutusScript u +pattern GYStakeValScript s = GYBuildPlutusScriptInlined s + +pattern GYStakeValReference :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYScript u -> GYBuildPlutusScript u +pattern GYStakeValReference r s = GYBuildPlutusScriptReference r s + +{-# COMPLETE GYStakeValScript, GYStakeValReference #-} + +gyStakeValScriptToSerialisedScript :: GYStakeValScript u -> Plutus.SerialisedScript +gyStakeValScriptToSerialisedScript (GYStakeValScript mp) = coerce mp & scriptToSerialisedScript & coerce +gyStakeValScriptToSerialisedScript (GYStakeValReference _ s) = scriptToSerialisedScript s & coerce + +gyStakeValScriptWitnessToApiPlutusSW :: + GYStakeValScript u -> + Api.S.ScriptRedeemer -> + Api.S.ExecutionUnits -> + Api.S.ScriptWitness Api.S.WitCtxStake ApiEra +gyStakeValScriptWitnessToApiPlutusSW (GYStakeValScript p) = stakeValidatorToApiPlutusScriptWitness p +gyStakeValScriptWitnessToApiPlutusSW (GYStakeValReference r s) = + referenceScriptToApiPlutusScriptWitness + r + s + Api.NoScriptDatumForStake + +stakeValidatorVersionFromWitness :: GYStakeValScript v -> PlutusVersion +stakeValidatorVersionFromWitness (GYStakeValScript mp) = fromSingPlutusVersion $ stakeValidatorVersion mp +stakeValidatorVersionFromWitness (GYStakeValReference _ s) = fromSingPlutusVersion $ stakeValidatorVersion $ coerce s + +type GYMintScript v = GYBuildScript v + +pattern GYMintScript :: () => VersionIsGreaterOrEqual v u => GYScript v -> GYBuildScript u +pattern GYMintScript s = GYBuildPlutusScript (GYBuildPlutusScriptInlined s) + +pattern GYMintReference :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYScript u -> GYBuildScript u +pattern GYMintReference r s = GYBuildPlutusScript (GYBuildPlutusScriptReference r s) + +gyMintingScriptWitnessToApiPlutusSW :: + GYBuildPlutusScript u -> + Api.S.ScriptRedeemer -> + Api.S.ExecutionUnits -> + Api.S.ScriptWitness Api.S.WitCtxMint ApiEra +gyMintingScriptWitnessToApiPlutusSW (GYBuildPlutusScriptInlined p) = mintingPolicyToApiPlutusScriptWitness p +gyMintingScriptWitnessToApiPlutusSW (GYBuildPlutusScriptReference r s) = + referenceScriptToApiPlutusScriptWitness + r + s + Api.NoScriptDatumForMint + +mintingPolicyIdFromWitness :: GYMintScript v -> GYMintingPolicyId +mintingPolicyIdFromWitness (GYBuildPlutusScript (GYBuildPlutusScriptInlined s)) = mintingPolicyId s +mintingPolicyIdFromWitness (GYBuildPlutusScript (GYBuildPlutusScriptReference _ s)) = mintingPolicyId s +mintingPolicyIdFromWitness (GYBuildSimpleScript (GYBuildSimpleScriptInlined s)) = simpleScriptToPolicyId s +mintingPolicyIdFromWitness (GYBuildSimpleScript (GYBuildSimpleScriptReference _ s)) = simpleScriptToPolicyId s + +mintingPolicyApiIdFromWitness :: GYMintScript v -> Api.PolicyId +mintingPolicyApiIdFromWitness = mintingPolicyIdToApi . mintingPolicyIdFromWitness \ No newline at end of file diff --git a/src/GeniusYield/Types/BuildWitness.hs b/src/GeniusYield/Types/BuildWitness.hs new file mode 100644 index 00000000..f05ef621 --- /dev/null +++ b/src/GeniusYield/Types/BuildWitness.hs @@ -0,0 +1,50 @@ +{- | +Module : GeniusYield.Types.BuildWitness +Copyright : (c) 2025 GYELD GMBH +License : Apache 2.0 +Maintainer : support@geniusyield.co +Stability : develop +-} +module GeniusYield.Types.BuildWitness ( + GYTxBuildWitness (..), + buildWitnessToApi, + unsafeBuildScriptWitnessToApi, +) where + +import Cardano.Api qualified as Api +import GeniusYield.Types.BuildScript +import GeniusYield.Types.Era +import GeniusYield.Types.Redeemer + +-- | Represents witness type. +data GYTxBuildWitness v + = -- | Key witness. + GYTxBuildWitnessKey + | -- | Script witness with associated script and redeemer. + GYTxBuildWitnessPlutusScript !(GYBuildPlutusScript v) !GYRedeemer + | -- | Simple script witness. + GYTxBuildWitnessSimpleScript !(GYBuildSimpleScript v) + deriving stock (Eq, Show) + +buildWitnessToApi :: GYTxBuildWitness v -> Api.Witness Api.WitCtxStake ApiEra +buildWitnessToApi GYTxBuildWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr +buildWitnessToApi (GYTxBuildWitnessPlutusScript v r) = + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) +buildWitnessToApi (GYTxBuildWitnessSimpleScript v) = Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ simpleScriptWitnessToApi v + +{- | Convert 'GYTxBuildWitness' to 'Api.ScriptWitness'. Throws an error if the input is 'GYTxBuildWitnessKey'. + +Would likely remove depending upon resolution of https://github.com/IntersectMBO/cardano-api/issues/722. +-} +unsafeBuildScriptWitnessToApi :: GYTxBuildWitness v -> Api.ScriptWitness Api.WitCtxStake ApiEra +unsafeBuildScriptWitnessToApi GYTxBuildWitnessKey = error "unsafeBuildScriptWitnessToApi: GYTxBuildWitnessKey" +unsafeBuildScriptWitnessToApi (GYTxBuildWitnessPlutusScript v r) = + gyStakeValScriptWitnessToApiPlutusSW + v + (redeemerToApi r) + (Api.ExecutionUnits 0 0) +unsafeBuildScriptWitnessToApi (GYTxBuildWitnessSimpleScript v) = simpleScriptWitnessToApi v diff --git a/src/GeniusYield/Types/Governance.hs b/src/GeniusYield/Types/Governance.hs new file mode 100644 index 00000000..5e5c9b06 --- /dev/null +++ b/src/GeniusYield/Types/Governance.hs @@ -0,0 +1,116 @@ +{- | +Module : GeniusYield.Types.Governance +Copyright : (c) 2025 GYELD GMBH +License : Apache 2.0 +Maintainer : support@geniusyield.co +Stability : develop +-} +module GeniusYield.Types.Governance ( + GYVote (..), + voteFromLedger, + voteToLedger, + GYVoter (..), + voterFromLedger, + voterToLedger, + GYGovActionId (..), + govActionIdFromLedger, + govActionIdToLedger, + GYVotingProcedure (..), + votingProcedureFromLedger, + votingProcedureToLedger, + GYVotingProcedures, + votingProceduresFromLedger, + votingProceduresToLedger, + combineVotingProcedures, + GYTxVotingProcedures, + combineTxVotingProcedures, +) where + +import Cardano.Api.Ledger (maybeToStrictMaybe, strictMaybeToMaybe) +import Cardano.Api.Ledger qualified as Ledger +import Cardano.Api.Shelley qualified as Api +import Cardano.Ledger.Api qualified as Ledger +import Data.Map.Strict qualified as Map +import Data.Word (Word16) +import GeniusYield.Imports (Map, (&)) +import GeniusYield.Types.Anchor +import GeniusYield.Types.BuildWitness +import GeniusYield.Types.Credential (GYCredential, credentialFromLedger, credentialToLedger) +import GeniusYield.Types.KeyHash +import GeniusYield.Types.KeyRole (GYKeyRole (..)) +import GeniusYield.Types.Tx (GYTxId, txIdFromApi, txIdToApi) +import Ouroboros.Consensus.Shelley.Eras qualified as Consensus + +-- | Vote on a governance proposal. +data GYVote = Yes | No | Abstain + deriving (Eq, Show, Ord, Enum, Bounded) + +voteToLedger :: GYVote -> Ledger.Vote +voteToLedger Yes = Ledger.VoteYes +voteToLedger No = Ledger.VoteNo +voteToLedger Abstain = Ledger.Abstain + +voteFromLedger :: Ledger.Vote -> GYVote +voteFromLedger Ledger.VoteYes = Yes +voteFromLedger Ledger.VoteNo = No +voteFromLedger Ledger.Abstain = Abstain + +-- | Voter. +data GYVoter + = CommitteeVoter !(GYCredential 'GYKeyRoleHotCommittee) + | DRepVoter !(GYCredential 'GYKeyRoleDRep) + | StakePoolVoter !(GYKeyHash 'GYKeyRoleStakePool) + deriving (Eq, Show, Ord) + +type Era = Ledger.EraCrypto Consensus.StandardConway + +voterToLedger :: GYVoter -> Ledger.Voter Era +voterToLedger (CommitteeVoter c) = Ledger.CommitteeVoter (credentialToLedger c) +voterToLedger (DRepVoter c) = Ledger.DRepVoter (credentialToLedger c) +voterToLedger (StakePoolVoter k) = Ledger.StakePoolVoter (keyHashToLedger k) + +voterFromLedger :: Ledger.Voter (Ledger.EraCrypto Consensus.StandardConway) -> GYVoter +voterFromLedger (Ledger.CommitteeVoter c) = CommitteeVoter (credentialFromLedger c) +voterFromLedger (Ledger.DRepVoter c) = DRepVoter (credentialFromLedger c) +voterFromLedger (Ledger.StakePoolVoter k) = StakePoolVoter (keyHashFromLedger k) + +data GYGovActionId = GYGovActionId + {gaidTxId :: !GYTxId, gaidIx :: !Word16} + deriving (Eq, Show, Ord) + +govActionIdToLedger :: GYGovActionId -> Ledger.GovActionId Era +govActionIdToLedger (GYGovActionId txId ix) = Ledger.GovActionId (txIdToApi txId & Api.toShelleyTxId) (Ledger.GovActionIx ix) + +govActionIdFromLedger :: Ledger.GovActionId Era -> GYGovActionId +govActionIdFromLedger (Ledger.GovActionId txId (Ledger.GovActionIx ix)) = GYGovActionId (txIdFromApi (Api.fromShelleyTxId txId)) ix + +-- | Voting procedure. +data GYVotingProcedure = GYVotingProcedure + { vpVote :: !GYVote + , vpAnchor :: !(Maybe GYAnchor) + } + deriving stock (Show, Eq, Ord) + +votingProcedureToLedger :: GYVotingProcedure -> Ledger.VotingProcedure Consensus.StandardConway +votingProcedureToLedger (GYVotingProcedure v a) = Ledger.VotingProcedure (voteToLedger v) (maybeToStrictMaybe (anchorToLedger <$> a)) + +votingProcedureFromLedger :: Ledger.VotingProcedure Consensus.StandardConway -> GYVotingProcedure +votingProcedureFromLedger (Ledger.VotingProcedure v a) = GYVotingProcedure (voteFromLedger v) (strictMaybeToMaybe (anchorFromLedger <$> a)) + +type GYVotingProcedures = Map GYVoter (Map GYGovActionId GYVotingProcedure) + +votingProceduresToLedger :: GYVotingProcedures -> Ledger.VotingProcedures Consensus.StandardConway +votingProceduresToLedger vp = Ledger.VotingProcedures $ Map.mapKeys voterToLedger $ Map.map (Map.mapKeys govActionIdToLedger . Map.map votingProcedureToLedger) vp + +votingProceduresFromLedger :: Ledger.VotingProcedures Consensus.StandardConway -> GYVotingProcedures +votingProceduresFromLedger (Ledger.VotingProcedures vp) = Map.mapKeys voterFromLedger $ Map.map (Map.mapKeys govActionIdFromLedger . Map.map votingProcedureFromLedger) vp + +-- | Combine two voting procedures. Here if a voter has voted on the same proposal in both procedures, the vote from the second procedure is taken. +combineVotingProcedures :: GYVotingProcedures -> GYVotingProcedures -> GYVotingProcedures +combineVotingProcedures = Map.unionWith (flip Map.union) + +type GYTxVotingProcedures v = Map GYVoter (GYTxBuildWitness v, Map GYGovActionId GYVotingProcedure) + +-- | Combine two voting procedures. Here if a voter has voted on the same proposal in both procedures, the vote from the second procedure is taken. Likewise, witness from the second map is taken in case of conflicts. +combineTxVotingProcedures :: GYTxVotingProcedures v -> GYTxVotingProcedures v -> GYTxVotingProcedures v +combineTxVotingProcedures = Map.unionWith (\(_w1, vp1) (w2, vp2) -> (w2, Map.union vp2 vp1)) diff --git a/src/GeniusYield/Types/Key.hs b/src/GeniusYield/Types/Key.hs index 464fa619..c53c1b8e 100644 --- a/src/GeniusYield/Types/Key.hs +++ b/src/GeniusYield/Types/Key.hs @@ -6,6 +6,8 @@ Maintainer : support@geniusyield.co Stability : develop -} module GeniusYield.Types.Key ( + ToShelleyWitnessSigningKey (..), + -- * Signing key GYSigningKey, signingKeyToLedger, diff --git a/src/GeniusYield/Types/Script.hs b/src/GeniusYield/Types/Script.hs index cb6de4d5..e7c415d7 100644 --- a/src/GeniusYield/Types/Script.hs +++ b/src/GeniusYield/Types/Script.hs @@ -43,8 +43,8 @@ module GeniusYield.Types.Script ( -- * MintingPolicy GYMintingPolicy, mintingPolicyId, + simpleScriptToPolicyId, mintingPolicyVersion, - mintingPolicyVersionFromWitness, mintingPolicyFromPlutus, mintingPolicyFromSerialisedScript, mintingPolicyToSerialisedScript, @@ -54,12 +54,6 @@ module GeniusYield.Types.Script ( mintingPolicyFromApi, mintingPolicyToApiPlutusScriptWitness, - -- * Witness for Minting Policy - GYMintScript (..), - mintingPolicyIdFromWitness, - gyMintScriptToSerialisedScript, - gyMintingScriptWitnessToApiPlutusSW, - -- ** File operations writeMintingPolicy, readMintingPolicy, @@ -67,7 +61,6 @@ module GeniusYield.Types.Script ( -- ** Selectors mintingPolicyCurrencySymbol, mintingPolicyApiId, - mintingPolicyApiIdFromWitness, -- * MintingPolicyId GYMintingPolicyId, @@ -80,7 +73,6 @@ module GeniusYield.Types.Script ( -- * StakeValidator GYStakeValidator, stakeValidatorVersion, - stakeValidatorVersionFromWitness, stakeValidatorFromPlutus, stakeValidatorFromSerialisedScript, stakeValidatorToSerialisedScript, @@ -88,11 +80,6 @@ module GeniusYield.Types.Script ( stakeValidatorFromApi, stakeValidatorToApiPlutusScriptWitness, - -- * Witness for stake validator - GYStakeValScript (..), - gyStakeValScriptToSerialisedScript, - gyStakeValScriptWitnessToApiPlutusSW, - -- ** Stake validator selectors stakeValidatorHash, stakeValidatorPlutusHash, @@ -252,16 +239,11 @@ type GYMintingPolicy v = GYScript v mintingPolicyVersion :: GYMintingPolicy v -> SingPlutusVersion v mintingPolicyVersion = coerce scriptVersion -mintingPolicyVersionFromWitness :: GYMintScript v -> PlutusVersion -mintingPolicyVersionFromWitness (GYMintScript mp) = fromSingPlutusVersion $ mintingPolicyVersion mp -mintingPolicyVersionFromWitness (GYMintReference _ s) = fromSingPlutusVersion $ mintingPolicyVersion $ coerce s - mintingPolicyId :: GYMintingPolicy v -> GYMintingPolicyId mintingPolicyId = coerce scriptApiHash -mintingPolicyIdFromWitness :: GYMintScript v -> GYMintingPolicyId -mintingPolicyIdFromWitness (GYMintScript p) = mintingPolicyId p -mintingPolicyIdFromWitness (GYMintReference _ s) = mintingPolicyId $ coerce s +simpleScriptToPolicyId :: GYSimpleScript -> GYMintingPolicyId +simpleScriptToPolicyId s = hashSimpleScript s & scriptHashToApi & coerce & mintingPolicyIdFromApi mintingPolicyFromPlutus :: forall v a. SingPlutusVersionI v => PlutusTx.CompiledCode a -> GYMintingPolicy v mintingPolicyFromPlutus = coerce (scriptFromPlutus @v) @@ -287,9 +269,6 @@ mintingPolicyCurrencySymbol = coerce scriptPlutusHash mintingPolicyApiId :: GYMintingPolicy v -> Api.PolicyId mintingPolicyApiId = coerce . mintingPolicyId -mintingPolicyApiIdFromWitness :: GYMintScript v -> Api.PolicyId -mintingPolicyApiIdFromWitness = coerce . mintingPolicyIdFromWitness - mintingPolicyToApiPlutusScriptWitness :: GYMintingPolicy v -> Api.ScriptRedeemer -> @@ -298,41 +277,6 @@ mintingPolicyToApiPlutusScriptWitness :: mintingPolicyToApiPlutusScriptWitness s = scriptToApiPlutusScriptWitness s Api.NoScriptDatumForMint -data GYMintScript (u :: PlutusVersion) where - -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYMintScript :: v `VersionIsGreaterOrEqual` u => GYScript v -> GYMintScript u - -- | Reference inputs can be only used in V2 & beyond transactions. - GYMintReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYMintScript v - -deriving instance Show (GYMintScript v) - -instance Eq (GYMintScript v) where - GYMintReference r s == GYMintReference r' s' = r == r' && s == s' - GYMintScript p == GYMintScript p' = defaultEq p p' - _ == _ = False - -instance Ord (GYMintScript v) where - GYMintReference r s `compare` GYMintReference r' s' = compare r r' <> compare s s' - GYMintReference _ _ `compare` _ = LT - GYMintScript p `compare` GYMintScript p' = defaultCompare p p' - GYMintScript _ `compare` _ = GT - -gyMintScriptToSerialisedScript :: GYMintScript u -> Plutus.SerialisedScript -gyMintScriptToSerialisedScript (GYMintScript mp) = coerce mp & scriptToSerialisedScript & coerce -gyMintScriptToSerialisedScript (GYMintReference _ s) = scriptToSerialisedScript s & coerce - -gyMintingScriptWitnessToApiPlutusSW :: - GYMintScript u -> - Api.S.ScriptRedeemer -> - Api.S.ExecutionUnits -> - Api.S.ScriptWitness Api.S.WitCtxMint ApiEra -gyMintingScriptWitnessToApiPlutusSW (GYMintScript p) = mintingPolicyToApiPlutusScriptWitness p -gyMintingScriptWitnessToApiPlutusSW (GYMintReference r s) = - referenceScriptToApiPlutusScriptWitness - r - s - Api.NoScriptDatumForMint - -- | Writes a minting policy to a file. writeMintingPolicy :: FilePath -> GYMintingPolicy v -> IO () writeMintingPolicy file = writeScriptCore "Minting Policy" file . coerce @@ -447,10 +391,6 @@ type GYStakeValidator v = GYScript v stakeValidatorVersion :: GYStakeValidator v -> SingPlutusVersion v stakeValidatorVersion = coerce scriptVersion -stakeValidatorVersionFromWitness :: GYStakeValScript v -> PlutusVersion -stakeValidatorVersionFromWitness (GYStakeValScript mp) = fromSingPlutusVersion $ stakeValidatorVersion mp -stakeValidatorVersionFromWitness (GYStakeValReference _ s) = fromSingPlutusVersion $ stakeValidatorVersion $ coerce s - stakeValidatorFromPlutus :: forall v a. SingPlutusVersionI v => PlutusTx.CompiledCode a -> GYStakeValidator v stakeValidatorFromPlutus = coerce (scriptFromPlutus @v) @@ -477,41 +417,6 @@ stakeValidatorToApiPlutusScriptWitness :: stakeValidatorToApiPlutusScriptWitness s = scriptToApiPlutusScriptWitness s Api.NoScriptDatumForStake -data GYStakeValScript (u :: PlutusVersion) where - -- | 'VersionIsGreaterOrEqual' restricts which version scripts can be used in this transaction. - GYStakeValScript :: v `VersionIsGreaterOrEqual` u => GYScript v -> GYStakeValScript u - -- | Reference inputs can be only used in V2 transactions. - GYStakeValReference :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYStakeValScript v - -deriving instance Show (GYStakeValScript v) - -instance Eq (GYStakeValScript v) where - GYStakeValReference r s == GYStakeValReference r' s' = r == r' && s == s' - GYStakeValScript p == GYStakeValScript p' = defaultEq p p' - _ == _ = False - -instance Ord (GYStakeValScript v) where - GYStakeValReference r s `compare` GYStakeValReference r' s' = compare r r' <> compare s s' - GYStakeValReference _ _ `compare` _ = LT - GYStakeValScript p `compare` GYStakeValScript p' = defaultCompare p p' - GYStakeValScript _ `compare` _ = GT - -gyStakeValScriptToSerialisedScript :: GYStakeValScript u -> Plutus.SerialisedScript -gyStakeValScriptToSerialisedScript (GYStakeValScript mp) = coerce mp & scriptToSerialisedScript & coerce -gyStakeValScriptToSerialisedScript (GYStakeValReference _ s) = scriptToSerialisedScript s & coerce - -gyStakeValScriptWitnessToApiPlutusSW :: - GYStakeValScript u -> - Api.S.ScriptRedeemer -> - Api.S.ExecutionUnits -> - Api.S.ScriptWitness Api.S.WitCtxStake ApiEra -gyStakeValScriptWitnessToApiPlutusSW (GYStakeValScript p) = stakeValidatorToApiPlutusScriptWitness p -gyStakeValScriptWitnessToApiPlutusSW (GYStakeValReference r s) = - referenceScriptToApiPlutusScriptWitness - r - s - Api.NoScriptDatumForStake - stakeValidatorHash :: GYStakeValidator v -> GYScriptHash stakeValidatorHash = coerce scriptHash diff --git a/src/GeniusYield/Types/TxCert.hs b/src/GeniusYield/Types/TxCert.hs index 4093ace6..7086ab1e 100644 --- a/src/GeniusYield/Types/TxCert.hs +++ b/src/GeniusYield/Types/TxCert.hs @@ -7,7 +7,9 @@ Stability : develop -} module GeniusYield.Types.TxCert ( GYTxCert, - GYTxCertWitness (..), + GYTxCertWitness, + pattern GYTxCertWitnessKey, + pattern GYTxCertWitnessScript, txCertToApi, mkStakeAddressRegistrationCertificate, mkStakeAddressDeregistrationCertificate, diff --git a/src/GeniusYield/Types/TxCert/Internal.hs b/src/GeniusYield/Types/TxCert/Internal.hs index 296cf732..5fd00aca 100644 --- a/src/GeniusYield/Types/TxCert/Internal.hs +++ b/src/GeniusYield/Types/TxCert/Internal.hs @@ -9,19 +9,22 @@ module GeniusYield.Types.TxCert.Internal ( GYTxCert (..), GYTxCert' (..), finaliseTxCert, - GYTxCertWitness (..), + GYTxCertWitness, + pattern GYTxCertWitnessKey, + pattern GYTxCertWitnessScript, txCertToApi, ) where import Cardano.Api qualified as Api import Data.Functor ((<&>)) import GeniusYield.Imports ((&)) +import GeniusYield.Types.BuildWitness (GYTxBuildWitness (..), buildWitnessToApi) import GeniusYield.Types.Certificate import GeniusYield.Types.Credential (stakeCredentialToApi) import GeniusYield.Types.Era import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import GeniusYield.Types.Redeemer -import GeniusYield.Types.Script +import GeniusYield.Types.TxIn (GYInScript) {- | A transaction certificate. @@ -32,37 +35,28 @@ Note that witness is not required for registering a stake address and for moving -} data GYTxCert v = GYTxCert { gyTxCertCertificate :: !GYCertificatePreBuild - , gyTxCertWitness :: !(Maybe (GYTxCertWitness v)) + , gyTxCertWitness :: !(Maybe (GYTxBuildWitness v)) } deriving (Eq, Show) data GYTxCert' v = GYTxCert' { gyTxCertCertificate' :: !GYCertificate - , gyTxCertWitness' :: !(Maybe (GYTxCertWitness v)) + , gyTxCertWitness' :: !(Maybe (GYTxBuildWitness v)) } deriving (Eq, Show) finaliseTxCert :: ApiProtocolParameters -> GYTxCert v -> GYTxCert' v finaliseTxCert pp (GYTxCert cert wit) = GYTxCert' (finaliseCert pp cert) wit --- | Represents witness type and associated information for a certificate. -data GYTxCertWitness v - = -- | Key witness. - GYTxCertWitnessKey - | -- | Script witness with associated script and redeemer. - GYTxCertWitnessScript !(GYStakeValScript v) !GYRedeemer - deriving stock (Eq, Show) +type GYTxCertWitness v = GYTxBuildWitness v + +pattern GYTxCertWitnessKey :: GYTxCertWitness v +pattern GYTxCertWitnessKey = GYTxBuildWitnessKey + +pattern GYTxCertWitnessScript :: GYInScript v -> GYRedeemer -> GYTxCertWitness v +pattern GYTxCertWitnessScript v r = GYTxBuildWitnessPlutusScript v r txCertToApi :: GYTxCert' v -> (Api.Certificate ApiEra, Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake ApiEra)) -txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, f wit'))) - where - f :: GYTxCertWitness v -> Api.Witness Api.WitCtxStake ApiEra - f GYTxCertWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr - f (GYTxCertWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) +txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, buildWitnessToApi wit'))) \ No newline at end of file diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index 9fd66a0b..3ef3fa66 100644 --- a/src/GeniusYield/Types/TxIn.hs +++ b/src/GeniusYield/Types/TxIn.hs @@ -7,16 +7,19 @@ Stability : develop -} module GeniusYield.Types.TxIn ( GYTxIn (..), - GYInScript (..), - GYInSimpleScript (..), + GYInScript, + pattern GYInScript, + pattern GYInReference, + GYInSimpleScript, + pattern GYInSimpleScript, + pattern GYInReferenceSimpleScript, inScriptVersion, GYTxInWitness (..), txInToApi, ) where import Cardano.Api qualified as Api -import Cardano.Api.Shelley qualified as Api -import Data.GADT.Compare (defaultEq) +import GeniusYield.Types.BuildScript import GeniusYield.Types.Datum import GeniusYield.Types.Era import GeniusYield.Types.PlutusVersion @@ -49,39 +52,28 @@ data GYTxInWitness v GYTxInWitnessSimpleScript !(GYInSimpleScript v) deriving stock (Eq, Show) -data GYInScript (u :: PlutusVersion) where - -- | 'VersionIsGreaterOrEqual' restricts which version validators can be used in this transaction. - GYInScript :: forall u v. v `VersionIsGreaterOrEqual` u => GYScript v -> GYInScript u - -- | Reference inputs can be only used in V2 transactions. - GYInReference :: forall v. v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYInScript v +type GYInScript = GYBuildPlutusScript --- | Returns the 'PlutusVersion' of the given 'GYInScript'. -inScriptVersion :: GYInScript v -> PlutusVersion -inScriptVersion (GYInReference _ s) = case scriptVersion s of - SingPlutusV3 -> PlutusV3 - SingPlutusV2 -> PlutusV2 -inScriptVersion (GYInScript v) = case validatorVersion v of - SingPlutusV3 -> PlutusV3 - SingPlutusV2 -> PlutusV2 - SingPlutusV1 -> PlutusV1 +pattern GYInScript :: () => v `VersionIsGreaterOrEqual` u => GYScript v -> GYBuildPlutusScript u +pattern GYInScript s = GYBuildPlutusScriptInlined s + +pattern GYInReference :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYScript u -> GYBuildPlutusScript u +pattern GYInReference ref s = GYBuildPlutusScriptReference ref s -deriving instance Show (GYInScript v) +{-# COMPLETE GYInScript, GYInReference #-} -instance Eq (GYInScript v) where - GYInReference ref1 script1 == GYInReference ref2 script2 = ref1 == ref2 && script1 == script2 - GYInScript v1 == GYInScript v2 = defaultEq v1 v2 - _ == _ = False +-- | Returns the 'PlutusVersion' of the given 'GYInScript'. +inScriptVersion :: GYInScript v -> PlutusVersion +inScriptVersion = buildPlutusScriptVersion -data GYInSimpleScript (u :: PlutusVersion) where - GYInSimpleScript :: !GYSimpleScript -> GYInSimpleScript u - GYInReferenceSimpleScript :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v +type GYInSimpleScript = GYBuildSimpleScript -deriving instance Show (GYInSimpleScript v) +pattern GYInSimpleScript :: GYSimpleScript -> GYBuildSimpleScript u +pattern GYInSimpleScript s = GYBuildSimpleScriptInlined s +pattern GYInReferenceSimpleScript :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYSimpleScript -> GYBuildSimpleScript u +pattern GYInReferenceSimpleScript ref s = GYBuildSimpleScriptReference ref s -instance Eq (GYInSimpleScript v) where - GYInSimpleScript s1 == GYInSimpleScript s2 = s1 == s2 - GYInReferenceSimpleScript ref1 s1 == GYInReferenceSimpleScript ref2 s2 = ref1 == ref2 && s1 == s2 - _ == _ = False +{-# COMPLETE GYInSimpleScript, GYInReferenceSimpleScript #-} {- | @@ -106,7 +98,4 @@ txInToApi useInline (GYTxIn oref m) = (txOutRefToApi oref, Api.BuildTxWith $ f m (redeemerToApi r) (Api.ExecutionUnits 0 0) f (GYTxInWitnessSimpleScript v) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.SimpleScriptWitness Api.SimpleScriptInConway $ h v - - h (GYInSimpleScript v) = Api.SScript $ simpleScriptToApi v - h (GYInReferenceSimpleScript ref s) = Api.SReferenceScript (txOutRefToApi ref) $ Just $ hashSimpleScript' s + Api.ScriptWitness Api.ScriptWitnessForSpending $ simpleScriptWitnessToApi v \ No newline at end of file diff --git a/src/GeniusYield/Types/TxWdrl.hs b/src/GeniusYield/Types/TxWdrl.hs index d853cbb3..e4c27e1f 100644 --- a/src/GeniusYield/Types/TxWdrl.hs +++ b/src/GeniusYield/Types/TxWdrl.hs @@ -7,7 +7,9 @@ Stability : develop -} module GeniusYield.Types.TxWdrl ( GYTxWdrl (..), - GYTxWdrlWitness (..), + GYTxWdrlWitness, + pattern GYTxWdrlWitnessKey, + pattern GYTxWdrlWitnessScript, txWdrlToApi, ) where @@ -15,9 +17,10 @@ import Cardano.Api qualified as Api import Cardano.Ledger.Coin qualified as Ledger import GeniusYield.Imports (Natural) import GeniusYield.Types.Address (GYStakeAddress, stakeAddressToApi) +import GeniusYield.Types.BuildWitness import GeniusYield.Types.Era import GeniusYield.Types.Redeemer -import GeniusYield.Types.Script +import GeniusYield.Types.TxIn (GYInScript) {- | Transaction withdrawal. @@ -27,28 +30,19 @@ in the transaction. data GYTxWdrl v = GYTxWdrl { gyTxWdrlStakeAddress :: !GYStakeAddress , gyTxWdrlAmount :: !Natural - , gyTxWdrlWitness :: !(GYTxWdrlWitness v) + , gyTxWdrlWitness :: !(GYTxBuildWitness v) } deriving (Eq, Show) --- | Represents witness type and associated information for tx withdrawals. -data GYTxWdrlWitness v - = -- | Key witness. - GYTxWdrlWitnessKey - | -- | Script witness with associated script and redeemer. - GYTxWdrlWitnessScript !(GYStakeValScript v) !GYRedeemer - deriving stock (Eq, Show) +type GYTxWdrlWitness v = GYTxBuildWitness v + +pattern GYTxWdrlWitnessKey :: GYTxWdrlWitness v +pattern GYTxWdrlWitnessKey = GYTxBuildWitnessKey + +pattern GYTxWdrlWitnessScript :: GYInScript v -> GYRedeemer -> GYTxWdrlWitness v +pattern GYTxWdrlWitnessScript v r = GYTxBuildWitnessPlutusScript v r txWdrlToApi :: GYTxWdrl v -> (Api.StakeAddress, Ledger.Coin, Api.BuildTxWith Api.BuildTx (Api.Witness Api.WitCtxStake ApiEra)) -txWdrlToApi (GYTxWdrl stakeAddr amt wit) = (stakeAddressToApi stakeAddr, Ledger.Coin (toInteger amt), Api.BuildTxWith $ f wit) - where - f :: GYTxWdrlWitness v -> Api.Witness Api.WitCtxStake ApiEra - f GYTxWdrlWitnessKey = Api.KeyWitness Api.KeyWitnessForStakeAddr - f (GYTxWdrlWitnessScript v r) = - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - gyStakeValScriptWitnessToApiPlutusSW - v - (redeemerToApi r) - (Api.ExecutionUnits 0 0) +txWdrlToApi (GYTxWdrl stakeAddr amt wit) = (stakeAddressToApi stakeAddr, Ledger.Coin (toInteger amt), Api.BuildTxWith $ buildWitnessToApi wit) diff --git a/src/GeniusYield/Types/Value.hs b/src/GeniusYield/Types/Value.hs index f120c407..766b374d 100644 --- a/src/GeniusYield/Types/Value.hs +++ b/src/GeniusYield/Types/Value.hs @@ -112,6 +112,7 @@ import Web.HttpApiData qualified as Web import Data.Either.Combinators (mapLeft) import Data.Foldable (for_) import Data.Hashable (Hashable (..)) +import GHC.IsList (IsList (fromList)) import GeniusYield.Types.Ada qualified as Ada import GeniusYield.Types.Era import GeniusYield.Types.Script @@ -207,7 +208,7 @@ valueSingleton ac n = valueMake $ Map.singleton ac n -- | Convert a 'GYValue' to a Cardano Api 'Api.Value' valueToApi :: GYValue -> Api.Value valueToApi v = - Api.valueFromList + fromList [ (assetClassToApi ac, Api.Quantity n) | (ac, n) <- valueToList v ] diff --git a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs index b9b45feb..1d79cdca 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs @@ -2,12 +2,8 @@ module GeniusYield.Test.Privnet.Committee ( committeeTests, ) where -import Control.Lens ((^.)) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) -import Data.Set qualified as Set import GeniusYield.Imports ((&)) -import GeniusYield.Test.Privnet.Asserts import GeniusYield.Test.Privnet.Ctx import GeniusYield.Test.Privnet.Setup import GeniusYield.TxBuilder diff --git a/tests/GeniusYield/Test/GYTxSkeleton.hs b/tests/GeniusYield/Test/GYTxSkeleton.hs index bb39d20b..010f1177 100644 --- a/tests/GeniusYield/Test/GYTxSkeleton.hs +++ b/tests/GeniusYield/Test/GYTxSkeleton.hs @@ -25,7 +25,6 @@ import GeniusYield.Types.PubKeyHash ( ) import GeniusYield.Types.Redeemer (GYRedeemer, unitRedeemer) import GeniusYield.Types.Script ( - GYMintScript (..), mintingPolicyFromApi, scriptFromCBOR, scriptToApi, @@ -56,6 +55,7 @@ import GeniusYield.TxBuilder.Class ( mustHaveRefInput, mustMint, ) +import GeniusYield.Types.BuildScript ------------------------------------------------------------------------------- -- Tests From 82de4259b0d034b71e9ac6a923392547298f14a8 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Sun, 12 Jan 2025 20:42:49 +0530 Subject: [PATCH 02/14] style(#389): fourmolu --- src/GeniusYield/Types/BuildScript.hs | 2 +- src/GeniusYield/Types/TxCert/Internal.hs | 2 +- src/GeniusYield/Types/TxIn.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/GeniusYield/Types/BuildScript.hs b/src/GeniusYield/Types/BuildScript.hs index 9fc59a1f..7787ee1e 100644 --- a/src/GeniusYield/Types/BuildScript.hs +++ b/src/GeniusYield/Types/BuildScript.hs @@ -163,4 +163,4 @@ mintingPolicyIdFromWitness (GYBuildSimpleScript (GYBuildSimpleScriptInlined s)) mintingPolicyIdFromWitness (GYBuildSimpleScript (GYBuildSimpleScriptReference _ s)) = simpleScriptToPolicyId s mintingPolicyApiIdFromWitness :: GYMintScript v -> Api.PolicyId -mintingPolicyApiIdFromWitness = mintingPolicyIdToApi . mintingPolicyIdFromWitness \ No newline at end of file +mintingPolicyApiIdFromWitness = mintingPolicyIdToApi . mintingPolicyIdFromWitness diff --git a/src/GeniusYield/Types/TxCert/Internal.hs b/src/GeniusYield/Types/TxCert/Internal.hs index 5fd00aca..4ad036ce 100644 --- a/src/GeniusYield/Types/TxCert/Internal.hs +++ b/src/GeniusYield/Types/TxCert/Internal.hs @@ -59,4 +59,4 @@ pattern GYTxCertWitnessScript v r = GYTxBuildWitnessPlutusScript v r txCertToApi :: GYTxCert' v -> (Api.Certificate ApiEra, Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake ApiEra)) -txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, buildWitnessToApi wit'))) \ No newline at end of file +txCertToApi (GYTxCert' cert wit) = (certificateToApi cert, wit <&> (\wit' -> (certificateToStakeCredential cert & stakeCredentialToApi, buildWitnessToApi wit'))) diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index 3ef3fa66..02d7164f 100644 --- a/src/GeniusYield/Types/TxIn.hs +++ b/src/GeniusYield/Types/TxIn.hs @@ -98,4 +98,4 @@ txInToApi useInline (GYTxIn oref m) = (txOutRefToApi oref, Api.BuildTxWith $ f m (redeemerToApi r) (Api.ExecutionUnits 0 0) f (GYTxInWitnessSimpleScript v) = - Api.ScriptWitness Api.ScriptWitnessForSpending $ simpleScriptWitnessToApi v \ No newline at end of file + Api.ScriptWitness Api.ScriptWitnessForSpending $ simpleScriptWitnessToApi v From 123525e3084812edf7059aca805e98524bc5a195 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Sun, 12 Jan 2025 21:18:28 +0530 Subject: [PATCH 03/14] feat(#389): consider key witnesses coming from voting procedures in total key witness estimate, also consider plutus scripts from voting procedures to know for collateral requirements --- src/GeniusYield/Transaction.hs | 30 ++++++++++++++++++++---------- tests/GeniusYield/Test/GYTxBody.hs | 3 +++ 2 files changed, 23 insertions(+), 10 deletions(-) diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index 4197bcb3..ffe76135 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -88,6 +88,7 @@ import Control.Arrow ((&&&)) import Control.Lens (view, (^.)) import Control.Monad.Random import Control.Monad.Trans.Except (runExceptT, throwE) +import Data.Bifunctor qualified import Data.ByteString.Lazy qualified as LBS import Data.Foldable ( Foldable (foldMap'), @@ -165,7 +166,7 @@ buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub sig certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs step :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) - step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised insOld outsOld stepStrat + step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised vps insOld outsOld stepStrat buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) buildTxLoop stepStrat n @@ -253,6 +254,8 @@ balanceTxStep :: [GYTxWdrl v] -> -- | certificates [GYTxCert' v] -> + -- | voting procedures + GYTxVotingProcedures v -> -- | transaction inputs [GYTxInDetailed v] -> -- | transaction outputs @@ -273,12 +276,13 @@ balanceTxStep mmint wdrls certs + vps ins outs cstrat = let adjustedOuts = map (adjustTxOut (minimumUTxO pp)) outs valueMint = maybe mempty fst mmint - needsCollateral = valueMint /= mempty || any (isScriptWitness . gyTxInWitness . gyTxInDet) ins || any (isCertScriptWitness . gyTxCertWitness') certs || any (isWdrlScriptWitness . gyTxWdrlWitness) wdrls + needsCollateral = valueMint /= mempty || any (isScriptWitness . gyTxInWitness . gyTxInDet) ins || any (isCertScriptWitness . gyTxCertWitness') certs || any (isPlutusScriptWitness . gyTxWdrlWitness) wdrls || any (isPlutusScriptWitness . fst) (Map.elems vps) (stakeCredDeregsAmt :: Natural, stakeCredRegsAmt :: Natural) = foldl' ( \acc@(!accDeregsAmt, !accRegsAmt) (gyTxCertCertificate' -> cert) -> case cert of @@ -346,10 +350,11 @@ balanceTxStep isScriptWitness GYTxInWitnessKey = False isScriptWitness GYTxInWitnessScript {} = True isScriptWitness GYTxInWitnessSimpleScript {} = False -- Simple (native) scripts don't require collateral. - isCertScriptWitness (Just GYTxCertWitnessScript {}) = True - isCertScriptWitness _ = False - isWdrlScriptWitness GYTxWdrlWitnessScript {} = True - isWdrlScriptWitness _ = False + isCertScriptWitness (Just p) = isPlutusScriptWitness p + isCertScriptWitness Nothing = False + + isPlutusScriptWitness (GYTxBuildWitnessPlutusScript {}) = True + isPlutusScriptWitness _ = False retColSup :: Api.BabbageEraOnwards ApiEra retColSup = Api.BabbageEraOnwardsConway @@ -396,8 +401,9 @@ finalizeGYBalancedTx fromIntegral $ countUnique $ mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) - <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferSCByKey sc]] - <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferSCByKey sc]] + <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferCByKey sc]] + <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferCByKey sc]] + <> [apkh | (a, GYTxBuildWitnessKey) <- Data.Bifunctor.second fst <$> Map.toList vps, Just apkh <- [voterToPKH a]] <> estimateKeyWitnessesFromInputs ins <> Set.toList signers where @@ -406,8 +412,12 @@ finalizeGYBalancedTx GYPaymentCredentialByKey pkh -> Just $ toPubKeyHash pkh GYPaymentCredentialByScript _ -> Nothing - preferSCByKey (GYStakeCredentialByKey pkh) = Just $ toPubKeyHash pkh - preferSCByKey _otherwise = Nothing + preferCByKey (GYCredentialByKey pkh) = Just $ toPubKeyHash pkh + preferCByKey _otherwise = Nothing + + voterToPKH (CommitteeVoter c) = preferCByKey c + voterToPKH (DRepVoter c) = preferCByKey c + voterToPKH (StakePoolVoter kh) = Just $ toPubKeyHash kh countUnique :: Ord a => [a] -> Int countUnique = Set.size . Set.fromList diff --git a/tests/GeniusYield/Test/GYTxBody.hs b/tests/GeniusYield/Test/GYTxBody.hs index d3267c11..fcffa4d2 100644 --- a/tests/GeniusYield/Test/GYTxBody.hs +++ b/tests/GeniusYield/Test/GYTxBody.hs @@ -151,6 +151,7 @@ balanceTxStepTests = Nothing [] [] + mempty [] [] GYRandomImproveMultiAsset @@ -163,6 +164,7 @@ balanceTxStepTests = Nothing [] [] + mempty [] [] GYRandomImproveMultiAsset @@ -175,6 +177,7 @@ balanceTxStepTests = (Just (valueSingleton (mockAsset "A") 100, [])) [] [] + mempty [] [] GYRandomImproveMultiAsset From 86800ef1ed85d8914f74535acaa08bb77749c6d5 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 12:06:13 +0530 Subject: [PATCH 04/14] feat(#389): add support for proposal procedures --- src/GeniusYield/Transaction.hs | 41 ++++++++-- src/GeniusYield/Transaction/Common.hs | 4 +- src/GeniusYield/TxBuilder/Common.hs | 17 ++++ src/GeniusYield/Types/Address.hs | 6 ++ src/GeniusYield/Types/Governance.hs | 113 +++++++++++++++++++++++++- src/GeniusYield/Types/Pool.hs | 4 +- src/GeniusYield/Types/Reexpose.hs | 3 + tests/GeniusYield/Test/GYTxBody.hs | 3 + 8 files changed, 181 insertions(+), 10 deletions(-) diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index ffe76135..ea209bec 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -74,6 +74,7 @@ import Cardano.Ledger.Alonzo.Scripts qualified as AlonzoScripts import Cardano.Ledger.Alonzo.Tx qualified as AlonzoTx import Cardano.Ledger.Binary qualified as CBOR import Cardano.Ledger.Binary.Crypto qualified as CBOR +import Cardano.Ledger.Conway.PParams qualified as Ledger import Cardano.Ledger.Core ( EraTx (sizeTxF), eraProtVerLow, @@ -160,13 +161,14 @@ buildUnsignedTxBody :: Set GYPubKeyHash -> Maybe GYTxMetadata -> GYTxVotingProcedures v -> + [(GYProposalProcedurePB, GYTxBuildWitness v)] -> m (Either GYBuildTxError GYTxBody) -buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata vps = buildTxLoop cstrat extraLovelaceStart +buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub signers mbTxMetadata vps pps = buildTxLoop cstrat extraLovelaceStart where certsFinalised = finaliseTxCert (gyBTxEnvProtocolParams env) <$> certs step :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError ([GYTxInDetailed v], GYUTxOs, [GYTxOut v])) - step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised vps insOld outsOld stepStrat + step stepStrat = fmap (first GYBuildTxBalancingError) . balanceTxStep env mmint wdrls certsFinalised vps pps insOld outsOld stepStrat buildTxLoop :: GYCoinSelectionStrategy -> Natural -> m (Either GYBuildTxError GYTxBody) buildTxLoop stepStrat n @@ -228,6 +230,7 @@ buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub sig , gybtxRefIns = refIns , gybtxMetadata = mbTxMetadata , gybtxVotingProcedures = vps + , gybtxProposalProcedures = pps } (length outsOld) @@ -256,6 +259,8 @@ balanceTxStep :: [GYTxCert' v] -> -- | voting procedures GYTxVotingProcedures v -> + -- | proposal procedures + [(GYProposalProcedurePB, GYTxBuildWitness v)] -> -- | transaction inputs [GYTxInDetailed v] -> -- | transaction outputs @@ -277,6 +282,7 @@ balanceTxStep wdrls certs vps + pps ins outs cstrat = @@ -312,12 +318,14 @@ balanceTxStep ) 0 certs + govActionDeposit :: Natural = pp ^. Ledger.ppGovActionDepositL & fromIntegral + govActionsAmt :: Natural = fromIntegral (length pps) * govActionDeposit -- 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 + spRegsAmt + adaSink = stakeCredRegsAmt + drepRegsAmt + spRegsAmt + govActionsAmt collaterals | needsCollateral = utxosFromUTxO collateral | otherwise = mempty @@ -353,7 +361,7 @@ balanceTxStep isCertScriptWitness (Just p) = isPlutusScriptWitness p isCertScriptWitness Nothing = False - isPlutusScriptWitness (GYTxBuildWitnessPlutusScript {}) = True + isPlutusScriptWitness GYTxBuildWitnessPlutusScript {} = True isPlutusScriptWitness _ = False retColSup :: Api.BabbageEraOnwards ApiEra @@ -381,6 +389,7 @@ finalizeGYBalancedTx , gybtxRefIns = utxosRefInputs , gybtxMetadata = mbTxMetadata , gybtxVotingProcedures = vps + , gybtxProposalProcedures = pps } = makeTransactionBodyAutoBalanceWrapper collaterals @@ -404,6 +413,7 @@ finalizeGYBalancedTx <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferCByKey sc]] <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferCByKey sc]] <> [apkh | (a, GYTxBuildWitnessKey) <- Data.Bifunctor.second fst <$> Map.toList vps, Just apkh <- [voterToPKH a]] + <> [apkh | (a, GYTxBuildWitnessKey) <- pps, Just apkh <- [propProcToPKH a]] <> estimateKeyWitnessesFromInputs ins <> Set.toList signers where @@ -419,6 +429,8 @@ finalizeGYBalancedTx voterToPKH (DRepVoter c) = preferCByKey c voterToPKH (StakePoolVoter kh) = Just $ toPubKeyHash kh + propProcToPKH (GYProposalProcedurePB {propProcPBReturnAddr}) = stakeAddressToCredential propProcPBReturnAddr & preferCByKey + countUnique :: Ord a => [a] -> Int countUnique = Set.size . Set.fromList @@ -564,6 +576,25 @@ finalizeGYBalancedTx & Map.map unsafeBuildScriptWitnessToApi ) in Just vpsApi >>= Api.mkFeatured + pps' = + if pps == mempty + then Nothing + else + let ppsApi = + Api.mkTxProposalProcedures + ( map + ( \(propProc, wit) -> + let propProc' = completeProposalProcedure propProc (pp ^. Ledger.ppGovActionDepositL & fromIntegral) & propProcToLedger + in ( propProc' + , case wit of + GYTxBuildWitnessKey -> Nothing + w@(GYTxBuildWitnessPlutusScript _ _) -> Just $ unsafeBuildScriptWitnessToApi w + w@(GYTxBuildWitnessSimpleScript _) -> Just $ unsafeBuildScriptWitnessToApi w + ) + ) + pps + ) + in Just ppsApi >>= Api.mkFeatured body :: Api.TxBodyContent Api.BuildTx ApiEra body = @@ -588,7 +619,7 @@ finalizeGYBalancedTx , Api.txUpdateProposal = Api.TxUpdateProposalNone , Api.txMintValue = mint , Api.txScriptValidity = Api.TxScriptValidityNone - , Api.txProposalProcedures = Nothing + , Api.txProposalProcedures = pps' , Api.txVotingProcedures = vps' , Api.txCurrentTreasuryValue = Nothing -- FIXME:? , Api.txTreasuryDonation = Nothing -- FIXME:? diff --git a/src/GeniusYield/Transaction/Common.hs b/src/GeniusYield/Transaction/Common.hs index 30253fd5..fe84f439 100644 --- a/src/GeniusYield/Transaction/Common.hs +++ b/src/GeniusYield/Transaction/Common.hs @@ -23,8 +23,9 @@ import GeniusYield.Imports import GeniusYield.Transaction.CBOR import GeniusYield.Types.Address import GeniusYield.Types.BuildScript +import GeniusYield.Types.BuildWitness import GeniusYield.Types.Era -import GeniusYield.Types.Governance (GYTxVotingProcedures) +import GeniusYield.Types.Governance (GYProposalProcedurePB, GYTxVotingProcedures) import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import GeniusYield.Types.PubKeyHash import GeniusYield.Types.Redeemer @@ -57,6 +58,7 @@ data GYBalancedTx v = GYBalancedTx , gybtxRefIns :: !GYUTxOs , gybtxMetadata :: !(Maybe GYTxMetadata) , gybtxVotingProcedures :: !(GYTxVotingProcedures v) + , gybtxProposalProcedures :: ![(GYProposalProcedurePB, GYTxBuildWitness v)] } -- | A further detailed version of 'GYTxIn', containing all information about a UTxO. diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 75706a7b..82b326c1 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -69,6 +69,7 @@ data GYTxSkeleton (v :: PlutusVersion) = GYTxSkeleton , gytxInvalidAfter :: !(Maybe GYSlot) , gytxMetadata :: !(Maybe GYTxMetadata) , gytxVotingProcedures :: !(GYTxSkeletonVotingProcedures v) + , gytxProposalProcedures :: !(GYTxSkeletonProposalProcedures v) } deriving Show @@ -85,6 +86,19 @@ instance Semigroup (GYTxSkeletonVotingProcedures v) where GYTxSkeletonVotingProceduresNone <> GYTxSkeletonVotingProcedures b = GYTxSkeletonVotingProcedures b GYTxSkeletonVotingProceduresNone <> GYTxSkeletonVotingProceduresNone = GYTxSkeletonVotingProceduresNone +data GYTxSkeletonProposalProcedures :: PlutusVersion -> Type where + GYTxSkeletonProposalProceduresNone :: GYTxSkeletonProposalProcedures v + GYTxSkeletonProposalProcedures :: VersionIsGreaterOrEqual v 'PlutusV3 => ![(GYProposalProcedurePB, GYTxBuildWitness v)] -> GYTxSkeletonProposalProcedures v + +deriving instance Show (GYTxSkeletonProposalProcedures v) +deriving instance Eq (GYTxSkeletonProposalProcedures v) + +instance Semigroup (GYTxSkeletonProposalProcedures v) where + GYTxSkeletonProposalProcedures a <> GYTxSkeletonProposalProcedures b = GYTxSkeletonProposalProcedures (a <> b) + GYTxSkeletonProposalProcedures a <> GYTxSkeletonProposalProceduresNone = GYTxSkeletonProposalProcedures a + GYTxSkeletonProposalProceduresNone <> GYTxSkeletonProposalProcedures b = GYTxSkeletonProposalProcedures b + GYTxSkeletonProposalProceduresNone <> GYTxSkeletonProposalProceduresNone = GYTxSkeletonProposalProceduresNone + data GYTxSkeletonRefIns :: PlutusVersion -> Type where GYTxSkeletonRefIns :: VersionIsGreaterOrEqual v 'PlutusV2 => !(Set GYTxOutRef) -> GYTxSkeletonRefIns v GYTxSkeletonNoRefIns :: GYTxSkeletonRefIns v @@ -119,6 +133,7 @@ emptyGYTxSkeleton = , gytxInvalidAfter = Nothing , gytxMetadata = Nothing , gytxVotingProcedures = GYTxSkeletonVotingProceduresNone + , gytxProposalProcedures = GYTxSkeletonProposalProceduresNone } instance Semigroup (GYTxSkeleton v) where @@ -135,6 +150,7 @@ instance Semigroup (GYTxSkeleton v) where , gytxInvalidAfter = combineInvalidAfter (gytxInvalidAfter x) (gytxInvalidAfter y) , gytxMetadata = gytxMetadata x <> gytxMetadata y , gytxVotingProcedures = gytxVotingProcedures x <> gytxVotingProcedures y + , gytxProposalProcedures = gytxProposalProcedures x <> gytxProposalProcedures y } where -- we keep only one input per utxo to spend @@ -296,6 +312,7 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk gytxSigs gytxMetadata (case gytxVotingProcedures of GYTxSkeletonVotingProceduresNone -> mempty; GYTxSkeletonVotingProcedures vp -> vp) + (case gytxProposalProcedures of GYTxSkeletonProposalProceduresNone -> mempty; GYTxSkeletonProposalProcedures pps -> pps) go :: GYUTxOs -> GYTxBuildResult -> [GYTxSkeleton v] -> m (Either GYBuildTxError GYTxBuildResult) go _ acc [] = pure $ Right $ reverseResult acc diff --git a/src/GeniusYield/Types/Address.hs b/src/GeniusYield/Types/Address.hs index 0d6d0c4c..f401fc34 100644 --- a/src/GeniusYield/Types/Address.hs +++ b/src/GeniusYield/Types/Address.hs @@ -41,6 +41,7 @@ module GeniusYield.Types.Address ( stakeAddressFromTextMaybe, unsafeStakeAddressFromText, stakeAddressToText, + stakeAddressToLedger, stakeAddressCredential, stakeAddressToCredential, stakeAddressFromCredential, @@ -89,6 +90,8 @@ import PlutusTx.Prelude qualified as PlutusTx import Text.Printf qualified as Printf import Web.HttpApiData qualified as Web +import Cardano.Api.Address qualified as Api +import Cardano.Ledger.Api qualified as Ledger import GeniusYield.Imports import GeniusYield.Types.Credential ( GYPaymentCredential, @@ -666,6 +669,9 @@ unsafeStakeAddressFromText t = stakeAddressToText :: GYStakeAddress -> Text.Text stakeAddressToText = Api.serialiseAddress . stakeAddressToApi +stakeAddressToLedger :: GYStakeAddress -> Ledger.RewardAccount Ledger.StandardCrypto +stakeAddressToLedger (stakeAddressToApi -> Api.StakeAddress nw sc) = Ledger.RewardAccount nw sc + {-# DEPRECATED stakeAddressCredential "Use stakeAddressToCredential." #-} -- | Get a stake credential from a stake address. This drops the network information. diff --git a/src/GeniusYield/Types/Governance.hs b/src/GeniusYield/Types/Governance.hs index 5e5c9b06..b150909a 100644 --- a/src/GeniusYield/Types/Governance.hs +++ b/src/GeniusYield/Types/Governance.hs @@ -24,6 +24,14 @@ module GeniusYield.Types.Governance ( combineVotingProcedures, GYTxVotingProcedures, combineTxVotingProcedures, + GYProposalProcedurePB (..), + GYProposalProcedure (..), + completeProposalProcedure, + propProcToLedger, + GYConstitution (..), + constitutionToLedger, + GYGovAction (..), + govActionToLedger, ) where import Cardano.Api.Ledger (maybeToStrictMaybe, strictMaybeToMaybe) @@ -31,13 +39,18 @@ import Cardano.Api.Ledger qualified as Ledger import Cardano.Api.Shelley qualified as Api import Cardano.Ledger.Api qualified as Ledger import Data.Map.Strict qualified as Map +import Data.Set qualified as Set import Data.Word (Word16) -import GeniusYield.Imports (Map, (&)) +import GeniusYield.Imports (Map, Natural, Set, (&)) +import GeniusYield.Types.Address (GYStakeAddress, stakeAddressToLedger) import GeniusYield.Types.Anchor import GeniusYield.Types.BuildWitness import GeniusYield.Types.Credential (GYCredential, credentialFromLedger, credentialToLedger) +import GeniusYield.Types.Epoch (GYEpochNo, epochNoToLedger) import GeniusYield.Types.KeyHash import GeniusYield.Types.KeyRole (GYKeyRole (..)) +import GeniusYield.Types.Reexpose (ProtVer, UnitInterval) +import GeniusYield.Types.Script (GYScriptHash, scriptHashToLedger) import GeniusYield.Types.Tx (GYTxId, txIdFromApi, txIdToApi) import Ouroboros.Consensus.Shelley.Eras qualified as Consensus @@ -114,3 +127,101 @@ type GYTxVotingProcedures v = Map GYVoter (GYTxBuildWitness v, Map GYGovActionId -- | Combine two voting procedures. Here if a voter has voted on the same proposal in both procedures, the vote from the second procedure is taken. Likewise, witness from the second map is taken in case of conflicts. combineTxVotingProcedures :: GYTxVotingProcedures v -> GYTxVotingProcedures v -> GYTxVotingProcedures v combineTxVotingProcedures = Map.unionWith (\(_w1, vp1) (w2, vp2) -> (w2, Map.union vp2 vp1)) + +data GYProposalProcedurePB = GYProposalProcedurePB + { propProcPBReturnAddr :: !GYStakeAddress + , propProcPBGovAction :: !GYGovAction + , propProcPBAnchor :: !GYAnchor + } + deriving stock (Show, Eq, Ord) + +data GYProposalProcedure = GYProposalProcedure + { propProcDeposit :: !Natural + , propProcReturnAddr :: !GYStakeAddress + , propProcGovAction :: !GYGovAction + , propProcAnchor :: !GYAnchor + } + deriving stock (Show, Eq, Ord) + +completeProposalProcedure :: GYProposalProcedurePB -> Natural -> GYProposalProcedure +completeProposalProcedure (GYProposalProcedurePB {..}) dep = + GYProposalProcedure + { propProcDeposit = dep + , propProcReturnAddr = propProcPBReturnAddr + , propProcGovAction = propProcPBGovAction + , propProcAnchor = propProcPBAnchor + } + +propProcToLedger :: GYProposalProcedure -> Ledger.ProposalProcedure Consensus.StandardConway +propProcToLedger (GYProposalProcedure {..}) = + Ledger.ProposalProcedure + { Ledger.pProcDeposit = fromIntegral propProcDeposit + , Ledger.pProcReturnAddr = stakeAddressToLedger propProcReturnAddr + , Ledger.pProcGovAction = govActionToLedger propProcGovAction + , Ledger.pProcAnchor = anchorToLedger propProcAnchor + } + +data GYConstitution = GYConstitution + { constitutionAnchor :: !GYAnchor + , constitutionScript :: !(Maybe GYScriptHash) + } + deriving stock (Eq, Ord, Show) + +constitutionToLedger :: GYConstitution -> Ledger.Constitution Consensus.StandardConway +constitutionToLedger (GYConstitution {..}) = Ledger.Constitution (anchorToLedger constitutionAnchor) (maybeToStrictMaybe $ scriptHashToLedger <$> constitutionScript) + +data GYGovAction + = ParameterChange + -- | Previous governance action id of `ParameterChange` type. + !(Maybe GYGovActionId) + -- | Proposed changes to PParams + !(Ledger.PParamsUpdate Consensus.StandardConway) + -- | Policy hash protection + !(Maybe GYScriptHash) + | HardForkInitiation + -- | Previous governance action id of `HardForkInitiation` type + !(Maybe GYGovActionId) + -- | Proposed new protocol version + !ProtVer + | TreasuryWithdrawals + -- | Proposed treasury withdrawals + !(Map GYStakeAddress Natural) + -- | Policy hash protection + !(Maybe GYScriptHash) + | NoConfidence + -- | Previous governance action id of `NoConfidence` or `UpdateCommittee` type + !(Maybe GYGovActionId) + | UpdateCommittee + -- | Previous governance action id of `UpdateCommittee` or `NoConfidence` type + !(Maybe GYGovActionId) + -- | Constitutional Committe members to be removed + !(Set (GYCredential 'GYKeyRoleColdCommittee)) + -- | Constitutional committee members to be added + !(Map (GYCredential 'GYKeyRoleColdCommittee) GYEpochNo) + -- | New Threshold + !UnitInterval + | NewConstitution + -- | Previous governance action id of `NewConstitution` type + !(Maybe GYGovActionId) + !GYConstitution + | InfoAction + deriving stock (Eq, Show, Ord) + +govActionToLedger :: GYGovAction -> Ledger.GovAction Consensus.StandardConway +govActionToLedger ga = case ga of + ParameterChange mgaid ppup msh -> Ledger.ParameterChange (castPurposeM mgaid) ppup (castScriptHashM msh) + HardForkInitiation mgaid pv -> Ledger.HardForkInitiation (castPurposeM mgaid) pv + TreasuryWithdrawals tw msh -> Ledger.TreasuryWithdrawals (Map.mapKeys stakeAddressToLedger $ Map.map fromIntegral tw) (castScriptHashM msh) + NoConfidence mgaid -> Ledger.NoConfidence (castPurposeM mgaid) + UpdateCommittee mgaid rm add thr -> Ledger.UpdateCommittee (castPurposeM mgaid) (Set.map credentialToLedger rm) (Map.mapKeys credentialToLedger $ Map.map epochNoToLedger add) thr + NewConstitution mgaid c -> Ledger.NewConstitution (castPurposeM mgaid) (constitutionToLedger c) + InfoAction -> Ledger.InfoAction + where + ms = maybeToStrictMaybe + + castPurpose :: GYGovActionId -> Ledger.GovPurposeId p Consensus.StandardConway + castPurpose = Ledger.GovPurposeId . govActionIdToLedger + + castPurposeM mgid = ms $ castPurpose <$> mgid + + castScriptHashM sh = ms $ scriptHashToLedger <$> sh \ No newline at end of file diff --git a/src/GeniusYield/Types/Pool.hs b/src/GeniusYield/Types/Pool.hs index 4db1c4bb..c6ff6b17 100644 --- a/src/GeniusYield/Types/Pool.hs +++ b/src/GeniusYield/Types/Pool.hs @@ -58,7 +58,7 @@ poolParamsToLedger GYPoolParams {..} = , Ledger.ppPledge = fromIntegral poolPledge , Ledger.ppCost = fromIntegral poolCost , Ledger.ppMargin = poolMargin - , Ledger.ppRewardAccount = Ledger.RewardAccount nw sc + , Ledger.ppRewardAccount = stakeAddressToLedger poolRewardAccount , Ledger.ppOwners = Set.map keyHashToLedger poolOwners , Ledger.ppRelays = fromList $ relayToLedger <$> poolRelays , Ledger.ppMetadata = ms $ anchorToLedgerPoolMetadata <$> poolMetadata @@ -81,8 +81,6 @@ poolParamsToLedger GYPoolParams {..} = } ms = maybeToStrictMaybe - Api.StakeAddress nw sc = stakeAddressToApi poolRewardAccount - poolParamsFromLedger :: Ledger.PoolParams Ledger.StandardCrypto -> GYPoolParams poolParamsFromLedger Ledger.PoolParams {..} = GYPoolParams diff --git a/src/GeniusYield/Types/Reexpose.hs b/src/GeniusYield/Types/Reexpose.hs index 4eef3010..99dbf473 100644 --- a/src/GeniusYield/Types/Reexpose.hs +++ b/src/GeniusYield/Types/Reexpose.hs @@ -11,6 +11,9 @@ module GeniusYield.Types.Reexpose ( Network (..), BoundedRational (..), UnitInterval, + ProtVer (..), + module X, ) where import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Binary.Version as X diff --git a/tests/GeniusYield/Test/GYTxBody.hs b/tests/GeniusYield/Test/GYTxBody.hs index fcffa4d2..506a725f 100644 --- a/tests/GeniusYield/Test/GYTxBody.hs +++ b/tests/GeniusYield/Test/GYTxBody.hs @@ -152,6 +152,7 @@ balanceTxStepTests = [] [] mempty + mempty [] [] GYRandomImproveMultiAsset @@ -165,6 +166,7 @@ balanceTxStepTests = [] [] mempty + mempty [] [] GYRandomImproveMultiAsset @@ -178,6 +180,7 @@ balanceTxStepTests = [] [] mempty + mempty [] [] GYRandomImproveMultiAsset From 131abda256e8ee9476d2e5b4e99cbbf703a1d2d8 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 12:07:11 +0530 Subject: [PATCH 05/14] style(#389): fourmolu --- src/GeniusYield/Types/Governance.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/GeniusYield/Types/Governance.hs b/src/GeniusYield/Types/Governance.hs index b150909a..a64f89a8 100644 --- a/src/GeniusYield/Types/Governance.hs +++ b/src/GeniusYield/Types/Governance.hs @@ -224,4 +224,4 @@ govActionToLedger ga = case ga of castPurposeM mgid = ms $ castPurpose <$> mgid - castScriptHashM sh = ms $ scriptHashToLedger <$> sh \ No newline at end of file + castScriptHashM sh = ms $ scriptHashToLedger <$> sh From e44af9b1e26be6233ad6eca24e04ef679e6904cc Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 12:10:04 +0530 Subject: [PATCH 06/14] style(#389): hlint suggestions --- src/GeniusYield/Transaction.hs | 2 +- src/GeniusYield/Types/Governance.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index ea209bec..ee93526f 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -429,7 +429,7 @@ finalizeGYBalancedTx voterToPKH (DRepVoter c) = preferCByKey c voterToPKH (StakePoolVoter kh) = Just $ toPubKeyHash kh - propProcToPKH (GYProposalProcedurePB {propProcPBReturnAddr}) = stakeAddressToCredential propProcPBReturnAddr & preferCByKey + propProcToPKH GYProposalProcedurePB {propProcPBReturnAddr} = stakeAddressToCredential propProcPBReturnAddr & preferCByKey countUnique :: Ord a => [a] -> Int countUnique = Set.size . Set.fromList diff --git a/src/GeniusYield/Types/Governance.hs b/src/GeniusYield/Types/Governance.hs index a64f89a8..389763ac 100644 --- a/src/GeniusYield/Types/Governance.hs +++ b/src/GeniusYield/Types/Governance.hs @@ -144,7 +144,7 @@ data GYProposalProcedure = GYProposalProcedure deriving stock (Show, Eq, Ord) completeProposalProcedure :: GYProposalProcedurePB -> Natural -> GYProposalProcedure -completeProposalProcedure (GYProposalProcedurePB {..}) dep = +completeProposalProcedure GYProposalProcedurePB {..} dep = GYProposalProcedure { propProcDeposit = dep , propProcReturnAddr = propProcPBReturnAddr @@ -153,7 +153,7 @@ completeProposalProcedure (GYProposalProcedurePB {..}) dep = } propProcToLedger :: GYProposalProcedure -> Ledger.ProposalProcedure Consensus.StandardConway -propProcToLedger (GYProposalProcedure {..}) = +propProcToLedger GYProposalProcedure {..} = Ledger.ProposalProcedure { Ledger.pProcDeposit = fromIntegral propProcDeposit , Ledger.pProcReturnAddr = stakeAddressToLedger propProcReturnAddr @@ -168,7 +168,7 @@ data GYConstitution = GYConstitution deriving stock (Eq, Ord, Show) constitutionToLedger :: GYConstitution -> Ledger.Constitution Consensus.StandardConway -constitutionToLedger (GYConstitution {..}) = Ledger.Constitution (anchorToLedger constitutionAnchor) (maybeToStrictMaybe $ scriptHashToLedger <$> constitutionScript) +constitutionToLedger GYConstitution {..} = Ledger.Constitution (anchorToLedger constitutionAnchor) (maybeToStrictMaybe $ scriptHashToLedger <$> constitutionScript) data GYGovAction = ParameterChange From 86ab1337d23c32601fa056fa13ed9e6ec9f95bdc Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 12:46:18 +0530 Subject: [PATCH 07/14] feat(#389): add tests for proposal procedure --- atlas-cardano.cabal | 1 + src/GeniusYield/TxBuilder/Class.hs | 8 ++++ src/GeniusYield/TxBuilder/Common.hs | 1 + src/GeniusYield/TxBuilder/User.hs | 7 ++- src/GeniusYield/Types.hs | 2 + .../GeniusYield/Test/Privnet/Committee.hs | 2 +- .../GeniusYield/Test/Privnet/DRep.hs | 2 +- tests-privnet/GeniusYield/Test/Privnet/Gov.hs | 44 +++++++++++++++++++ .../GeniusYield/Test/Privnet/StakePool.hs | 2 +- tests-privnet/atlas-privnet-tests.hs | 2 + 10 files changed, 67 insertions(+), 4 deletions(-) create mode 100644 tests-privnet/GeniusYield/Test/Privnet/Gov.hs diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index b44daf74..c96c2aee 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -375,6 +375,7 @@ test-suite atlas-privnet-tests GeniusYield.Test.Privnet.Blueprint GeniusYield.Test.Privnet.Committee GeniusYield.Test.Privnet.DRep + GeniusYield.Test.Privnet.Gov GeniusYield.Test.Privnet.SimpleScripts GeniusYield.Test.Privnet.Stake GeniusYield.Test.Privnet.Stake.Key diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index 84f7cdb6..75857dbe 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -86,6 +86,8 @@ module GeniusYield.TxBuilder.Class ( mustHaveOptionalOutput, mustHaveTxMetadata, mustHaveVotingProcedures, + mustHaveProposalProcedure, + mustHaveProposalProcedures, mustMint, mustHaveWithdrawal, mustHaveCertificate, @@ -821,6 +823,12 @@ mustHaveTxMetadata m = emptyGYTxSkeleton {gytxMetadata = m} mustHaveVotingProcedures :: VersionIsGreaterOrEqual v 'PlutusV3 => GYTxVotingProcedures v -> GYTxSkeleton v mustHaveVotingProcedures vp = emptyGYTxSkeleton {gytxVotingProcedures = GYTxSkeletonVotingProcedures vp} +mustHaveProposalProcedure :: VersionIsGreaterOrEqual v 'PlutusV3 => GYProposalProcedurePB -> GYTxBuildWitness v -> GYTxSkeleton v +mustHaveProposalProcedure pp w = mustHaveProposalProcedures [(pp, w)] + +mustHaveProposalProcedures :: VersionIsGreaterOrEqual v 'PlutusV3 => [(GYProposalProcedurePB, GYTxBuildWitness v)] -> GYTxSkeleton v +mustHaveProposalProcedures pps = emptyGYTxSkeleton {gytxProposalProcedures = GYTxSkeletonProposalProcedures pps} + mustMint :: GYBuildScript v -> GYRedeemer -> GYTokenName -> Integer -> GYTxSkeleton v mustMint _ _ _ 0 = mempty mustMint p r tn n = emptyGYTxSkeleton {gytxMint = Map.singleton p (Map.singleton tn n, r)} diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 82b326c1..e52a426a 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -9,6 +9,7 @@ module GeniusYield.TxBuilder.Common ( GYTxSkeleton (..), GYTxSkeletonRefIns (..), GYTxSkeletonVotingProcedures (..), + GYTxSkeletonProposalProcedures (..), emptyGYTxSkeleton, gyTxSkeletonRefInsToList, gyTxSkeletonRefInsSet, diff --git a/src/GeniusYield/TxBuilder/User.hs b/src/GeniusYield/TxBuilder/User.hs index 56697eae..da99d78a 100644 --- a/src/GeniusYield/TxBuilder/User.hs +++ b/src/GeniusYield/TxBuilder/User.hs @@ -7,6 +7,7 @@ module GeniusYield.TxBuilder.User ( userPkh, userPaymentPkh, userStakePkh, + userStakeAddress, userVKey, userPaymentVKey, userPaymentSKey', @@ -21,7 +22,8 @@ import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import GeniusYield.Imports -import GeniusYield.Types.Address (GYAddress) +import GeniusYield.Types (GYCredential (GYCredentialByKey), GYNetworkId (GYTestnetPreprod)) +import GeniusYield.Types.Address (GYAddress, GYStakeAddress, stakeAddressFromCredential) import GeniusYield.Types.Key import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash) import GeniusYield.Types.PubKeyHash (AsPubKeyHash (toPubKeyHash), GYPubKeyHash) @@ -73,6 +75,9 @@ userPaymentPkh = paymentKeyHash . paymentVerificationKey . userPaymentSKey userStakePkh :: User -> Maybe GYStakeKeyHash userStakePkh = fmap (stakeKeyHash . stakeVerificationKey) . userStakeSKey +userStakeAddress :: GYNetworkId -> User -> Maybe GYStakeAddress +userStakeAddress nid u = userStakePkh u >>= \skh -> Just $ stakeAddressFromCredential nid $ GYCredentialByKey skh + userCollateralDumb :: User -> Maybe (GYTxOutRef, Bool) userCollateralDumb User {userCollateral} = (\UserCollateral {userCollateralRef, userCollateralCheck} -> (userCollateralRef, userCollateralCheck)) <$> userCollateral diff --git a/src/GeniusYield/Types.hs b/src/GeniusYield/Types.hs index 0015300c..5702478f 100644 --- a/src/GeniusYield/Types.hs +++ b/src/GeniusYield/Types.hs @@ -130,6 +130,7 @@ module GeniusYield.Types ( -- | Cost in the amount of lovelace ber byte. CoinPerByte (..), ppCoinsPerUTxOByteL, + ppGovActionDepositL, ) where import Cardano.Ledger.Api ( @@ -158,6 +159,7 @@ import Cardano.Ledger.Api ( ppRhoL, ppTauL, ) +import Cardano.Ledger.Conway.PParams (ppGovActionDepositL) import GeniusYield.Types.Ada as X import GeniusYield.Types.Address as X import GeniusYield.Types.Anchor as X diff --git a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs index 1d79cdca..6bb37c2c 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs @@ -35,7 +35,7 @@ exerciseCommittee ctx info = do submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey fundUser, GYSomeSigningKey coldKey] info $ "Successfully authorized hot key, with tx id: " <> show txId - let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.io") (hashAnchorData "we are awesome") + let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.co") (hashAnchorData "we are awesome") info "Resigning cold key" txIdUnreg <- ctxRun ctx fundUser $ do txBody <- buildTxBody $ mustHaveCertificate $ mkCommitteeColdKeyResignationCertificate coldCred (Just anchor) diff --git a/tests-privnet/GeniusYield/Test/Privnet/DRep.hs b/tests-privnet/GeniusYield/Test/Privnet/DRep.hs index c895c18f..35279b60 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/DRep.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/DRep.hs @@ -40,7 +40,7 @@ exerciseDRep ctx info = do pure tid info $ "Successfully registered drep, with tx id: " <> show txId info "Updating drep" - let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.io") (hashAnchorData "we are awesome") + let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.co") (hashAnchorData "we are awesome") (txIdUpd, mdrepS) <- ctxRun ctx fundUser $ do txBody <- buildTxBody $ mustHaveCertificate $ mkDRepUpdateCertificate drepCred (Just anchor) GYTxCertWitnessKey gyLogInfo' "" $ "txBody: " <> show txBody diff --git a/tests-privnet/GeniusYield/Test/Privnet/Gov.hs b/tests-privnet/GeniusYield/Test/Privnet/Gov.hs new file mode 100644 index 00000000..77e3c7a4 --- /dev/null +++ b/tests-privnet/GeniusYield/Test/Privnet/Gov.hs @@ -0,0 +1,44 @@ +module GeniusYield.Test.Privnet.Gov ( + govTests, +) where + +import Control.Lens ((^.)) +import Data.Maybe (fromJust) +import GeniusYield.Test.Privnet.Asserts +import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Setup +import GeniusYield.Test.Privnet.Stake.Utils +import GeniusYield.Transaction.CoinSelection +import GeniusYield.TxBuilder +import GeniusYield.Types +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) + +govTests :: Setup -> TestTree +govTests setup = + testGroup + "gov" + [ testCaseSteps "able to exercise proposal & voting procedure" $ \info -> withSetup info setup $ \ctx -> do + exerciseGov ctx info + ] + +exerciseGov :: Ctx -> (String -> IO ()) -> IO () +exerciseGov ctx info = do + newUser <- newTempUserCtx ctx (ctxUserF ctx) (valueFromLovelace 100_000_000) (CreateUserConfig {cucGenerateStakeKey = True, cucGenerateCollateral = True}) + pp <- ctxRunQuery ctx protocolParams + info $ "Gov action deposit: " <> show (pp ^. ppGovActionDepositL) + info $ "Generated new user: " <> show newUser + info "Registering stake credential of this user" + registerStakeCredentialSteps GYRandomImproveMultiAsset newUser Nothing info ctx + info "Registered stake credential of this user" + txId <- ctxRun ctx newUser $ do + fundAddr <- ownChangeAddress + fundBalI <- queryBalance fundAddr + let propProc = GYProposalProcedurePB {propProcPBReturnAddr = fromJust $ userStakeAddress (ctxNetworkId ctx) newUser, propProcPBGovAction = InfoAction, propProcPBAnchor = GYAnchor {anchorUrl = unsafeTextToUrl "https://www.geniusyield.co", anchorDataHash = hashAnchorData "we are awesome"}} + txBody <- buildTxBody $ mustHaveProposalProcedure @'PlutusV3 propProc GYTxBuildWitnessKey + gyLogInfo' "" $ "txBody: " <> show txBody + tid <- submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey newUser] + fundBalF <- queryBalance fundAddr + gyLogInfo' "" $ "Balance lost: " <> show (valueMinus fundBalI fundBalF) + pure tid + info $ "Successfully exercised proposal procedure, with tx id: " <> show txId diff --git a/tests-privnet/GeniusYield/Test/Privnet/StakePool.hs b/tests-privnet/GeniusYield/Test/Privnet/StakePool.hs index a1049136..aef13ac1 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/StakePool.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/StakePool.hs @@ -61,7 +61,7 @@ exerciseStakePool ctx info = do assertBool "Stake pool not found" $ Set.member (stakePoolIdToApi stakePoolVKH) sps info $ "Successfully registered stakePool, with tx id: " <> show txId info "Updating stakePool" - let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.io") (hashAnchorData "we are awesome") + let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.co") (hashAnchorData "we are awesome") poolParams' = poolParams {poolMetadata = Just anchor} txIdUpd <- ctxRun ctx fundUser $ do txBody <- buildTxBody $ mustHaveCertificate $ mkStakePoolRegistrationCertificate poolParams' diff --git a/tests-privnet/atlas-privnet-tests.hs b/tests-privnet/atlas-privnet-tests.hs index 71d420fd..d35fd44f 100644 --- a/tests-privnet/atlas-privnet-tests.hs +++ b/tests-privnet/atlas-privnet-tests.hs @@ -20,6 +20,7 @@ import GeniusYield.Test.Privnet.Committee qualified import GeniusYield.Test.Privnet.Ctx import GeniusYield.Test.Privnet.DRep qualified import GeniusYield.Test.Privnet.Examples qualified +import GeniusYield.Test.Privnet.Gov qualified import GeniusYield.Test.Privnet.Setup import GeniusYield.Test.Privnet.SimpleScripts qualified import GeniusYield.Test.Privnet.Stake qualified @@ -70,4 +71,5 @@ main = do , GeniusYield.Test.Privnet.DRep.drepTests setup , GeniusYield.Test.Privnet.StakePool.stakePoolTests setup , GeniusYield.Test.Privnet.Committee.committeeTests setup + , GeniusYield.Test.Privnet.Gov.govTests setup ] From 74a83aeb7d32d22de3ac5c8f3b38cd6edcab7244 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 13:42:09 +0530 Subject: [PATCH 08/14] feat(#389): add test for voting --- src/GeniusYield/TxBuilder/User.hs | 2 +- .../GeniusYield/Test/Privnet/Committee.hs | 17 +++++++++++++---- tests-privnet/GeniusYield/Test/Privnet/Gov.hs | 14 +++++++++++++- 3 files changed, 27 insertions(+), 6 deletions(-) diff --git a/src/GeniusYield/TxBuilder/User.hs b/src/GeniusYield/TxBuilder/User.hs index da99d78a..6f64bb79 100644 --- a/src/GeniusYield/TxBuilder/User.hs +++ b/src/GeniusYield/TxBuilder/User.hs @@ -22,7 +22,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import GeniusYield.Imports -import GeniusYield.Types (GYCredential (GYCredentialByKey), GYNetworkId (GYTestnetPreprod)) +import GeniusYield.Types (GYCredential (GYCredentialByKey), GYNetworkId) import GeniusYield.Types.Address (GYAddress, GYStakeAddress, stakeAddressFromCredential) import GeniusYield.Types.Key import GeniusYield.Types.PaymentKeyHash (GYPaymentKeyHash) diff --git a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs index 6bb37c2c..f166cb26 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs @@ -1,5 +1,6 @@ module GeniusYield.Test.Privnet.Committee ( committeeTests, + delegateHotKey, ) where import Data.Map.Strict qualified as Map @@ -19,23 +20,31 @@ committeeTests setup = exerciseCommittee ctx info ] -exerciseCommittee :: Ctx -> (String -> IO ()) -> IO () -exerciseCommittee ctx info = do +getColdCred :: GYSigningKey kr -> GYCredential kr +getColdCred = GYCredentialByKey . verificationKeyHash . getVerificationKey + +delegateHotKey :: Ctx -> (String -> IO ()) -> User -> IO (GYSigningKey 'GYKeyRoleColdCommittee, GYSigningKey 'GYKeyRoleHotCommittee) +delegateHotKey ctx info fundUser = do info "Generating a hot committee key" hotSKey <- generateSigningKey @'GYKeyRoleHotCommittee let hotCred = GYCredentialByKey $ verificationKeyHash $ getVerificationKey hotSKey info $ "Generated hot key: " <> show hotSKey <> ", with corresponding credential: " <> show hotCred let coldKey = ctxCommittee ctx & ctxCommitteeMembers & Map.findMin & fst - coldCred = GYCredentialByKey $ verificationKeyHash $ getVerificationKey coldKey + coldCred = getColdCred coldKey info $ "Cold key: " <> show coldKey <> ", with corresponding credential: " <> show coldCred - let fundUser = ctxUserF ctx txId <- ctxRun ctx fundUser $ do txBody <- buildTxBody $ mustHaveCertificate $ mkCommitteeHotKeyAuthCertificate coldCred hotCred gyLogInfo' "" $ "txBody: " <> show txBody submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey fundUser, GYSomeSigningKey coldKey] info $ "Successfully authorized hot key, with tx id: " <> show txId + pure (coldKey, hotSKey) +exerciseCommittee :: Ctx -> (String -> IO ()) -> IO () +exerciseCommittee ctx info = do + let fundUser = ctxUserF ctx + (coldKey, _) <- delegateHotKey ctx info fundUser let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.co") (hashAnchorData "we are awesome") + coldCred = getColdCred coldKey info "Resigning cold key" txIdUnreg <- ctxRun ctx fundUser $ do txBody <- buildTxBody $ mustHaveCertificate $ mkCommitteeColdKeyResignationCertificate coldCred (Just anchor) diff --git a/tests-privnet/GeniusYield/Test/Privnet/Gov.hs b/tests-privnet/GeniusYield/Test/Privnet/Gov.hs index 77e3c7a4..ea9933a1 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Gov.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Gov.hs @@ -3,8 +3,9 @@ module GeniusYield.Test.Privnet.Gov ( ) where import Control.Lens ((^.)) +import Data.Map.Strict qualified as Map import Data.Maybe (fromJust) -import GeniusYield.Test.Privnet.Asserts +import GeniusYield.Test.Privnet.Committee import GeniusYield.Test.Privnet.Ctx import GeniusYield.Test.Privnet.Setup import GeniusYield.Test.Privnet.Stake.Utils @@ -42,3 +43,14 @@ exerciseGov ctx info = do gyLogInfo' "" $ "Balance lost: " <> show (valueMinus fundBalI fundBalF) pure tid info $ "Successfully exercised proposal procedure, with tx id: " <> show txId + (_, hotSKey) <- delegateHotKey ctx info newUser + txIdVote <- ctxRun ctx newUser $ do + fundAddr <- ownChangeAddress + fundBalI <- queryBalance fundAddr + txBody <- buildTxBody $ mustHaveVotingProcedures @'PlutusV3 (Map.fromList [(CommitteeVoter (GYCredentialByKey $ verificationKeyHash $ getVerificationKey hotSKey), (GYTxBuildWitnessKey, Map.fromList [(GYGovActionId {gaidTxId = txId, gaidIx = 0}, GYVotingProcedure Yes Nothing)]))]) + gyLogInfo' "" $ "txBody: " <> show txBody + tid <- submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey newUser, GYSomeSigningKey hotSKey] + fundBalF <- queryBalance fundAddr + gyLogInfo' "" $ "Balance lost: " <> show (valueMinus fundBalI fundBalF) + pure tid + info $ "Successfully voted on the proposal, with tx id: " <> show txIdVote From 2c6828fea87d2bde7241f5ffda88e481cc609507 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 14:29:35 +0530 Subject: [PATCH 09/14] feat(#389): removing use of GYTxMintScript etc. from all places --- CHANGELOG.md | 1 + src/GeniusYield/Api/TestTokens.hs | 2 +- src/GeniusYield/Test/Privnet/Examples/Misc.hs | 2 +- src/GeniusYield/Test/Utils.hs | 2 +- src/GeniusYield/Transaction.hs | 6 +++--- src/GeniusYield/TxBuilder/Common.hs | 4 ++-- src/GeniusYield/Types/BuildScript.hs | 4 ++-- src/GeniusYield/Types/TxCert.hs | 21 ++++++++++--------- .../GeniusYield/Test/Privnet/Committee.hs | 8 +++---- .../GeniusYield/Test/Privnet/DRep.hs | 6 +++--- tests-privnet/GeniusYield/Test/Privnet/Gov.hs | 2 +- .../GeniusYield/Test/Privnet/Stake/Utils.hs | 8 +++---- tests/GeniusYield/Test/GYTxSkeleton.hs | 12 +++++------ 13 files changed, 40 insertions(+), 38 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f315d8e1..660e85e4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,7 @@ * Update default value of `GYAwaitTxParameters` to now have 100 max attempts. * `GYInScript` and `GYStakeValScript` are now defined as a type synonyms around `GYBuildPlutusScript` whereas `GYMintScript` is a type synonym around `GYBuildScript` which now also includes simple scripts (besides plutus scripts). Pattern synonyms are provided for backwards compatibility. These and related functions such as `stakeValidatorVersionFromWitness`, `gyStakeValScriptToSerialisedScript` are now exported from `GeniusYield.Types.BuildScript` instead of `GeniusYield.Types.Script`. * `GYTxWdrlWitness`, `GYTxCertWitness` are now defined as a type synonyms around generic `GYTxBuildWitness` and now also includes simple scripts. Pattern synonyms are provided to maintain backwards compatibility. +* Adds support for governance actions, namely proposal procedures & voting procedures. ## 0.7.0 diff --git a/src/GeniusYield/Api/TestTokens.hs b/src/GeniusYield/Api/TestTokens.hs index 95cb8930..e33ca38a 100644 --- a/src/GeniusYield/Api/TestTokens.hs +++ b/src/GeniusYield/Api/TestTokens.hs @@ -30,6 +30,6 @@ mintTestTokens tn amt = do let txSkeleton = mustHaveInput (GYTxIn utxo GYTxInWitnessKey) - <> mustMint (GYMintScript policy) unitRedeemer tn amt' + <> mustMint (GYBuildPlutusScript $ GYBuildPlutusScriptInlined policy) unitRedeemer tn amt' return (GYToken (mintingPolicyId policy) tn, txSkeleton) diff --git a/src/GeniusYield/Test/Privnet/Examples/Misc.hs b/src/GeniusYield/Test/Privnet/Examples/Misc.hs index 533f6597..07deb9d0 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Misc.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Misc.hs @@ -42,7 +42,7 @@ tests setup = txBodyMint <- buildTxBody $ mustHaveInput (GYTxIn utxoAsParam GYTxInWitnessKey) - <> mustMint (GYMintReference refScript policyAsScript) unitRedeemer tn amt + <> mustMint (GYBuildPlutusScript $ GYBuildPlutusScriptReference refScript policyAsScript) unitRedeemer tn amt signAndSubmitConfirmed_ txBodyMint -- wait a tiny bit. diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index bfa72152..300de808 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -218,7 +218,7 @@ mintTestAssets tokens = do buildTxBody @PlutusV2 $ foldMap ( \(tk, amt) -> - mustMint (GYMintScript $ fakePolicy tk) unitRedeemer (fakeCoinName tk) $ toInteger amt + mustMint (GYBuildPlutusScript $ GYBuildPlutusScriptInlined $ fakePolicy tk) unitRedeemer (fakeCoinName tk) $ toInteger amt ) tokens signAndSubmitConfirmed_ txBody diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index ee93526f..af67a18d 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -252,7 +252,7 @@ balanceTxStep :: (HasCallStack, MonadRandom m) => GYBuildTxEnv -> -- | minting - Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -> + Maybe (GYValue, [(GYBuildScript v, GYRedeemer)]) -> -- | withdrawals [GYTxWdrl v] -> -- | certificates @@ -410,8 +410,8 @@ finalizeGYBalancedTx fromIntegral $ countUnique $ mapMaybe (extractPaymentPkhFromAddress . utxoAddress) (utxosToList collaterals) - <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxWdrlWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferCByKey sc]] - <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxCertWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferCByKey sc]] + <> [apkh | GYTxWdrl {gyTxWdrlWitness = GYTxBuildWitnessKey, gyTxWdrlStakeAddress = saddr} <- wdrls, let sc = stakeAddressToCredential saddr, Just apkh <- [preferCByKey sc]] + <> [apkh | cert@GYTxCert' {gyTxCertWitness' = Just GYTxBuildWitnessKey} <- certs, let sc = certificateToStakeCredential $ gyTxCertCertificate' cert, Just apkh <- [preferCByKey sc]] <> [apkh | (a, GYTxBuildWitnessKey) <- Data.Bifunctor.second fst <$> Map.toList vps, Just apkh <- [voterToPKH a]] <> [apkh | (a, GYTxBuildWitnessKey) <- pps, Just apkh <- [propProcToPKH a]] <> estimateKeyWitnessesFromInputs ins diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index e52a426a..246ec645 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -237,7 +237,7 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk helper :: GYUTxOs -> GYTxSkeleton v -> m (Either GYBuildTxError GYTxBody) helper ownUtxos' GYTxSkeleton {..} = do - let gytxMint' :: Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) + let gytxMint' :: Maybe (GYValue, [(GYBuildScript v, GYRedeemer)]) gytxMint' | null gytxMint = Nothing | otherwise = @@ -249,7 +249,7 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk let refIns = gyTxSkeletonRefInsToList gytxRefIns <> [r | GYTxIn {gyTxInWitness = GYTxInWitnessScript (GYInReference r _) _ _} <- gytxIns] - <> [r | GYMintReference r _ <- Map.keys gytxMint] + <> [r | GYBuildPlutusScript (GYBuildPlutusScriptReference r _) <- Map.keys gytxMint] allRefUtxos <- utxosAtTxOutRefs $ (gyTxInTxOutRef <$> gytxIns) diff --git a/src/GeniusYield/Types/BuildScript.hs b/src/GeniusYield/Types/BuildScript.hs index 7787ee1e..beda9514 100644 --- a/src/GeniusYield/Types/BuildScript.hs +++ b/src/GeniusYield/Types/BuildScript.hs @@ -156,11 +156,11 @@ gyMintingScriptWitnessToApiPlutusSW (GYBuildPlutusScriptReference r s) = s Api.NoScriptDatumForMint -mintingPolicyIdFromWitness :: GYMintScript v -> GYMintingPolicyId +mintingPolicyIdFromWitness :: GYBuildScript v -> GYMintingPolicyId mintingPolicyIdFromWitness (GYBuildPlutusScript (GYBuildPlutusScriptInlined s)) = mintingPolicyId s mintingPolicyIdFromWitness (GYBuildPlutusScript (GYBuildPlutusScriptReference _ s)) = mintingPolicyId s mintingPolicyIdFromWitness (GYBuildSimpleScript (GYBuildSimpleScriptInlined s)) = simpleScriptToPolicyId s mintingPolicyIdFromWitness (GYBuildSimpleScript (GYBuildSimpleScriptReference _ s)) = simpleScriptToPolicyId s -mintingPolicyApiIdFromWitness :: GYMintScript v -> Api.PolicyId +mintingPolicyApiIdFromWitness :: GYBuildScript v -> Api.PolicyId mintingPolicyApiIdFromWitness = mintingPolicyIdToApi . mintingPolicyIdFromWitness diff --git a/src/GeniusYield/Types/TxCert.hs b/src/GeniusYield/Types/TxCert.hs index 7086ab1e..b4e137d2 100644 --- a/src/GeniusYield/Types/TxCert.hs +++ b/src/GeniusYield/Types/TxCert.hs @@ -25,6 +25,7 @@ module GeniusYield.Types.TxCert ( import GeniusYield.Imports (Natural) import GeniusYield.Types.Anchor (GYAnchor) +import GeniusYield.Types.BuildWitness import GeniusYield.Types.Certificate import GeniusYield.Types.Credential (GYCredential, GYStakeCredential) import GeniusYield.Types.Delegatee (GYDelegatee) @@ -35,7 +36,7 @@ import GeniusYield.Types.Pool import GeniusYield.Types.TxCert.Internal -- | Post conway, newer stake address registration certificate also require a witness. -mkStakeAddressRegistrationCertificate :: GYStakeCredential -> GYTxCertWitness v -> GYTxCert v +mkStakeAddressRegistrationCertificate :: GYStakeCredential -> GYTxBuildWitness v -> GYTxCert v mkStakeAddressRegistrationCertificate sc wit = GYTxCert (GYStakeAddressRegistrationCertificatePB sc) (Just wit) {- | Note that deregistration certificate requires following preconditions: @@ -44,10 +45,10 @@ mkStakeAddressRegistrationCertificate sc wit = GYTxCert (GYStakeAddressRegistrat 2. The corresponding rewards balance is zero. -} -mkStakeAddressDeregistrationCertificate :: GYStakeCredential -> GYTxCertWitness v -> GYTxCert v +mkStakeAddressDeregistrationCertificate :: GYStakeCredential -> GYTxBuildWitness v -> GYTxCert v mkStakeAddressDeregistrationCertificate sc wit = GYTxCert (GYStakeAddressDeregistrationCertificatePB sc) (Just wit) -mkStakeAddressDelegationCertificate :: GYStakeCredential -> GYDelegatee -> GYTxCertWitness v -> GYTxCert v +mkStakeAddressDelegationCertificate :: GYStakeCredential -> GYDelegatee -> GYTxBuildWitness v -> GYTxCert v mkStakeAddressDelegationCertificate sc del wit = GYTxCert (GYStakeAddressDelegationCertificatePB sc del) (Just wit) {- | Note that delegation certificate requires following preconditions: @@ -58,7 +59,7 @@ mkStakeAddressDelegationCertificate sc del wit = GYTxCert (GYStakeAddressDelegat 3. Signature from the corresponding DRep key. -} -mkDRepRegistrationCertificate :: GYCredential 'GYKeyRoleDRep -> Maybe GYAnchor -> GYTxCertWitness v -> GYTxCert v +mkDRepRegistrationCertificate :: GYCredential 'GYKeyRoleDRep -> Maybe GYAnchor -> GYTxBuildWitness v -> GYTxCert v mkDRepRegistrationCertificate cred anchor wit = GYTxCert (GYDRepRegistrationCertificatePB cred anchor) (Just wit) {- | Note that update certificate requires following preconditions: @@ -67,7 +68,7 @@ mkDRepRegistrationCertificate cred anchor wit = GYTxCert (GYDRepRegistrationCert 2. Signature from the corresponding DRep key. -} -mkDRepUpdateCertificate :: GYCredential 'GYKeyRoleDRep -> Maybe GYAnchor -> GYTxCertWitness v -> GYTxCert v +mkDRepUpdateCertificate :: GYCredential 'GYKeyRoleDRep -> Maybe GYAnchor -> GYTxBuildWitness v -> GYTxCert v mkDRepUpdateCertificate cred anchor wit = GYTxCert (GYDRepUpdateCertificatePB cred anchor) (Just wit) {- | Note that unregistration certificate requires following preconditions: @@ -78,7 +79,7 @@ mkDRepUpdateCertificate cred anchor wit = GYTxCert (GYDRepUpdateCertificatePB cr 3. Signature from the corresponding DRep key. -} -mkDRepUnregistrationCertificate :: GYCredential 'GYKeyRoleDRep -> Natural -> GYTxCertWitness v -> GYTxCert v +mkDRepUnregistrationCertificate :: GYCredential 'GYKeyRoleDRep -> Natural -> GYTxBuildWitness v -> GYTxCert v mkDRepUnregistrationCertificate cred refund wit = GYTxCert (GYDRepUnregistrationCertificatePB cred refund) (Just wit) {- | Note that stake pool registration certificate requires following preconditions: @@ -94,7 +95,7 @@ mkDRepUnregistrationCertificate cred refund wit = GYTxCert (GYDRepUnregistration mkStakePoolRegistrationCertificate :: GYPoolParams -> GYTxCert v -mkStakePoolRegistrationCertificate pp = GYTxCert (GYStakePoolRegistrationCertificatePB pp) (Just GYTxCertWitnessKey) +mkStakePoolRegistrationCertificate pp = GYTxCert (GYStakePoolRegistrationCertificatePB pp) (Just GYTxBuildWitnessKey) {- | Note that stake pool retirement certificate requires following preconditions: @@ -107,7 +108,7 @@ mkStakePoolRegistrationCertificate pp = GYTxCert (GYStakePoolRegistrationCertifi Note that deposit made earlier is returned at epoch transition. -} mkStakePoolRetirementCertificate :: GYKeyHash 'GYKeyRoleStakePool -> GYEpochNo -> GYTxCert v -mkStakePoolRetirementCertificate poolId epoch = GYTxCert (GYStakePoolRetirementCertificatePB poolId epoch) (Just GYTxCertWitnessKey) +mkStakePoolRetirementCertificate poolId epoch = GYTxCert (GYStakePoolRetirementCertificatePB poolId epoch) (Just GYTxBuildWitnessKey) {- | Note that committee hot key auth certificate requires following preconditions: @@ -118,7 +119,7 @@ mkStakePoolRetirementCertificate poolId epoch = GYTxCert (GYStakePoolRetirementC 3. Signature from the corresponding cold committee key. -} mkCommitteeHotKeyAuthCertificate :: GYCredential 'GYKeyRoleColdCommittee -> GYCredential 'GYKeyRoleHotCommittee -> GYTxCert v -mkCommitteeHotKeyAuthCertificate cold hot = GYTxCert (GYCommitteeHotKeyAuthCertificatePB cold hot) (Just GYTxCertWitnessKey) +mkCommitteeHotKeyAuthCertificate cold hot = GYTxCert (GYCommitteeHotKeyAuthCertificatePB cold hot) (Just GYTxBuildWitnessKey) {- | Note that committee cold key resignation certificate requires following preconditions: @@ -133,4 +134,4 @@ mkCommitteeColdKeyResignationCertificate :: -- | Potential explanation for resignation. Maybe GYAnchor -> GYTxCert v -mkCommitteeColdKeyResignationCertificate cold anchor = GYTxCert (GYCommitteeColdKeyResignationCertificatePB cold anchor) (Just GYTxCertWitnessKey) +mkCommitteeColdKeyResignationCertificate cold anchor = GYTxCert (GYCommitteeColdKeyResignationCertificatePB cold anchor) (Just GYTxBuildWitnessKey) diff --git a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs index f166cb26..fbfc03cb 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs @@ -23,13 +23,13 @@ committeeTests setup = getColdCred :: GYSigningKey kr -> GYCredential kr getColdCred = GYCredentialByKey . verificationKeyHash . getVerificationKey -delegateHotKey :: Ctx -> (String -> IO ()) -> User -> IO (GYSigningKey 'GYKeyRoleColdCommittee, GYSigningKey 'GYKeyRoleHotCommittee) -delegateHotKey ctx info fundUser = do +delegateHotKey :: Ctx -> (String -> IO ()) -> User -> Int -> IO (GYSigningKey 'GYKeyRoleColdCommittee, GYSigningKey 'GYKeyRoleHotCommittee) +delegateHotKey ctx info fundUser ix = do info "Generating a hot committee key" hotSKey <- generateSigningKey @'GYKeyRoleHotCommittee let hotCred = GYCredentialByKey $ verificationKeyHash $ getVerificationKey hotSKey info $ "Generated hot key: " <> show hotSKey <> ", with corresponding credential: " <> show hotCred - let coldKey = ctxCommittee ctx & ctxCommitteeMembers & Map.findMin & fst + let coldKey = ctxCommittee ctx & ctxCommitteeMembers & Map.toList & (!! ix) & fst coldCred = getColdCred coldKey info $ "Cold key: " <> show coldKey <> ", with corresponding credential: " <> show coldCred txId <- ctxRun ctx fundUser $ do @@ -42,7 +42,7 @@ delegateHotKey ctx info fundUser = do exerciseCommittee :: Ctx -> (String -> IO ()) -> IO () exerciseCommittee ctx info = do let fundUser = ctxUserF ctx - (coldKey, _) <- delegateHotKey ctx info fundUser + (coldKey, _) <- delegateHotKey ctx info fundUser 0 let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.co") (hashAnchorData "we are awesome") coldCred = getColdCred coldKey info "Resigning cold key" diff --git a/tests-privnet/GeniusYield/Test/Privnet/DRep.hs b/tests-privnet/GeniusYield/Test/Privnet/DRep.hs index 35279b60..fbac16d1 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/DRep.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/DRep.hs @@ -30,7 +30,7 @@ exerciseDRep ctx info = do txId <- ctxRun ctx fundUser $ do fundAddr <- ownChangeAddress fundBalI <- queryBalance fundAddr - txBody <- buildTxBody $ mustHaveCertificate $ mkDRepRegistrationCertificate drepCred Nothing GYTxCertWitnessKey + txBody <- buildTxBody $ mustHaveCertificate $ mkDRepRegistrationCertificate drepCred Nothing GYTxBuildWitnessKey gyLogInfo' "" $ "txBody: " <> show txBody tid <- submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey fundUser, GYSomeSigningKey drepSKey] fundBalF <- queryBalance fundAddr @@ -42,7 +42,7 @@ exerciseDRep ctx info = do info "Updating drep" let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.co") (hashAnchorData "we are awesome") (txIdUpd, mdrepS) <- ctxRun ctx fundUser $ do - txBody <- buildTxBody $ mustHaveCertificate $ mkDRepUpdateCertificate drepCred (Just anchor) GYTxCertWitnessKey + txBody <- buildTxBody $ mustHaveCertificate $ mkDRepUpdateCertificate drepCred (Just anchor) GYTxBuildWitnessKey gyLogInfo' "" $ "txBody: " <> show txBody tid <- submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey fundUser, GYSomeSigningKey drepSKey] drepS <- drepState drepCred @@ -55,7 +55,7 @@ exerciseDRep ctx info = do Nothing -> assertFailure "Drep state not found" Just drepS -> do txIdUnreg <- ctxRun ctx fundUser $ do - txBody <- buildTxBody $ mustHaveCertificate $ mkDRepUnregistrationCertificate drepCred (drepDeposit drepS) GYTxCertWitnessKey + txBody <- buildTxBody $ mustHaveCertificate $ mkDRepUnregistrationCertificate drepCred (drepDeposit drepS) GYTxBuildWitnessKey gyLogInfo' "" $ "txBody: " <> show txBody submitTxBodyConfirmed txBody [GYSomeSigningKey $ userPaymentSKey fundUser, GYSomeSigningKey drepSKey] info $ "Successfully unregistered drep, with tx id: " <> show txIdUnreg diff --git a/tests-privnet/GeniusYield/Test/Privnet/Gov.hs b/tests-privnet/GeniusYield/Test/Privnet/Gov.hs index ea9933a1..a5e74903 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Gov.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Gov.hs @@ -43,7 +43,7 @@ exerciseGov ctx info = do gyLogInfo' "" $ "Balance lost: " <> show (valueMinus fundBalI fundBalF) pure tid info $ "Successfully exercised proposal procedure, with tx id: " <> show txId - (_, hotSKey) <- delegateHotKey ctx info newUser + (_, hotSKey) <- delegateHotKey ctx info newUser 1 txIdVote <- ctxRun ctx newUser $ do fundAddr <- ownChangeAddress fundBalI <- queryBalance fundAddr diff --git a/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs index f23d4587..7e3b060a 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs @@ -57,11 +57,11 @@ resolveStakeAddress privnetNetworkId user = stakeAddressFromCredential privnetNe resolveSigningRequirement :: User -> Maybe GYScriptHash -> [GYSomeSigningKey] resolveSigningRequirement User' {..} mstakeValHash = GYSomeSigningKey userPaymentSKey' : ([userStakeSKey' & fromJust & GYSomeSigningKey | isNothing mstakeValHash]) -resolveCertWitness :: Bool -> GYTxCertWitness 'PlutusV2 -resolveCertWitness isScript = if not isScript then GYTxCertWitnessKey else GYTxCertWitnessScript (GYStakeValScript aStakeValidator) unitRedeemer +resolveCertWitness :: Bool -> GYTxBuildWitness 'PlutusV2 +resolveCertWitness isScript = if not isScript then GYTxBuildWitnessKey else GYTxBuildWitnessPlutusScript (GYStakeValScript aStakeValidator) unitRedeemer -resolveWdrlWitness :: Bool -> GYTxWdrlWitness 'PlutusV2 -resolveWdrlWitness isScript = if not isScript then GYTxWdrlWitnessKey else GYTxWdrlWitnessScript (GYStakeValScript aStakeValidator) unitRedeemer +resolveWdrlWitness :: Bool -> GYTxBuildWitness 'PlutusV2 +resolveWdrlWitness isScript = if not isScript then GYTxBuildWitnessKey else GYTxBuildWitnessPlutusScript (GYStakeValScript aStakeValidator) unitRedeemer -- This will check if we are able to register a stake credential without it's witness. registerStakeCredentialSteps :: GYCoinSelectionStrategy -> User -> Maybe GYScriptHash -> (String -> IO ()) -> Ctx -> IO () diff --git a/tests/GeniusYield/Test/GYTxSkeleton.hs b/tests/GeniusYield/Test/GYTxSkeleton.hs index 010f1177..7a798c2d 100644 --- a/tests/GeniusYield/Test/GYTxSkeleton.hs +++ b/tests/GeniusYield/Test/GYTxSkeleton.hs @@ -257,20 +257,20 @@ mockSlot = mockSlot' 1000 mockSlot' :: Integer -> GYSlot mockSlot' = fromJust . slotFromInteger -mockMint :: (Map (GYMintScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer)) +mockMint :: (Map (GYBuildScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer)) mockMint = mockMint' 10 -mockBurn :: (Map (GYMintScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer)) +mockBurn :: (Map (GYBuildScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer)) mockBurn = mockMint' (-10) -mockMint' :: Integer -> Map (GYMintScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer) +mockMint' :: Integer -> Map (GYBuildScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer) mockMint' n = Map.singleton mockMintingPolicy (Map.singleton mockTokenName n, unitRedeemer) -mockMintSum :: (Map (GYMintScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer)) +mockMintSum :: (Map (GYBuildScript 'PlutusV2) (Map GYTokenName Integer, GYRedeemer)) mockMintSum = Map.singleton mockMintingPolicy (Map.fromList [(mockTokenName, 10), (mockTokenName1, 20)], unitRedeemer) -mockMintingPolicy :: GYMintScript 'PlutusV2 -mockMintingPolicy = GYMintScript $ mintingPolicyFromApi @'PlutusV2 $ scriptToApi $ fromJust $ scriptFromCBOR @'PlutusV2 "5902a70100003232323232323232323232323232323232223232323232533301253330123371000290000a51153330123017001153330123375e980129d8799fd87a9f581c0312bfe52db5be9f48d9ee30270ba6459b4277c4b6a0a363b9c5f6e4ffd87a80ff003014301337546601c44a6660240022c2a6660286032666601c00a90001199980780ca4000eb4dd58009bab3016301730153754602c0022602c00226004602e0026eb0c050c054c04cdd500109919299980a299980a19805180b001180b000899805180b180b800980b180b8010a5014a22c60286ea8c054c058c058c058c040c050dd500198099baa30183300b300a482038a82860584cc02cc0292080beedb581614bd700b0b0a4c2c6666601844460046eacc05400cdd48011bab3013300e3012375400246666601a44460046eb4c05800cdd480b00090008a40002c602460226ea80114ccc03ccdc3a4000601c00426eb8c04400458c03c004dd51807980818071baa0012232323232323232325333014533301433710004002294454ccc050cdc380100089919299980b180d802099b88375a60300046eb4c060004528180b002180a8020a5014a22a66602866ebc0180144ccc050c02cc058c05c020c02cc058c05c01d288a503012002301100237540046ea8008c044008c040008c038dd500118069baa0022300f300937540024601e6600466e95200233002375000297ae0330023374a6660129452002480012f5c097ae057404644446600e44a666016002200a2a66601a66ebcc030c03c0040184c010c038c03c0044c008c040004004dd48009111980211299980400089128008a99980519baf3009300c00100413005300c00113002300d00100123230022330020020012300223300200200123007300730070015573eaae755cd2ab9e5742ae8922102475900370e90011ba5480001" +mockMintingPolicy :: GYBuildScript 'PlutusV2 +mockMintingPolicy = GYBuildPlutusScript $ GYBuildPlutusScriptInlined $ mintingPolicyFromApi @'PlutusV2 $ scriptToApi $ fromJust $ scriptFromCBOR @'PlutusV2 "5902a70100003232323232323232323232323232323232223232323232533301253330123371000290000a51153330123017001153330123375e980129d8799fd87a9f581c0312bfe52db5be9f48d9ee30270ba6459b4277c4b6a0a363b9c5f6e4ffd87a80ff003014301337546601c44a6660240022c2a6660286032666601c00a90001199980780ca4000eb4dd58009bab3016301730153754602c0022602c00226004602e0026eb0c050c054c04cdd500109919299980a299980a19805180b001180b000899805180b180b800980b180b8010a5014a22c60286ea8c054c058c058c058c040c050dd500198099baa30183300b300a482038a82860584cc02cc0292080beedb581614bd700b0b0a4c2c6666601844460046eacc05400cdd48011bab3013300e3012375400246666601a44460046eb4c05800cdd480b00090008a40002c602460226ea80114ccc03ccdc3a4000601c00426eb8c04400458c03c004dd51807980818071baa0012232323232323232325333014533301433710004002294454ccc050cdc380100089919299980b180d802099b88375a60300046eb4c060004528180b002180a8020a5014a22a66602866ebc0180144ccc050c02cc058c05c020c02cc058c05c01d288a503012002301100237540046ea8008c044008c040008c038dd500118069baa0022300f300937540024601e6600466e95200233002375000297ae0330023374a6660129452002480012f5c097ae057404644446600e44a666016002200a2a66601a66ebcc030c03c0040184c010c038c03c0044c008c040004004dd48009111980211299980400089128008a99980519baf3009300c00100413005300c00113002300d00100123230022330020020012300223300200200123007300730070015573eaae755cd2ab9e5742ae8922102475900370e90011ba5480001" mockTokenName :: GYTokenName mockTokenName = unsafeTokenNameFromHex "abc123" From 57ba38838d146f6650d8e94e5ea72bb784319f6e Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 14:32:41 +0530 Subject: [PATCH 10/14] feat(#389): remove usage of stakevalscript --- tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs index 7e3b060a..270361d0 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs @@ -58,10 +58,10 @@ resolveSigningRequirement :: User -> Maybe GYScriptHash -> [GYSomeSigningKey] resolveSigningRequirement User' {..} mstakeValHash = GYSomeSigningKey userPaymentSKey' : ([userStakeSKey' & fromJust & GYSomeSigningKey | isNothing mstakeValHash]) resolveCertWitness :: Bool -> GYTxBuildWitness 'PlutusV2 -resolveCertWitness isScript = if not isScript then GYTxBuildWitnessKey else GYTxBuildWitnessPlutusScript (GYStakeValScript aStakeValidator) unitRedeemer +resolveCertWitness isScript = if not isScript then GYTxBuildWitnessKey else GYTxBuildWitnessPlutusScript (GYBuildPlutusScriptInlined aStakeValidator) unitRedeemer resolveWdrlWitness :: Bool -> GYTxBuildWitness 'PlutusV2 -resolveWdrlWitness isScript = if not isScript then GYTxBuildWitnessKey else GYTxBuildWitnessPlutusScript (GYStakeValScript aStakeValidator) unitRedeemer +resolveWdrlWitness isScript = if not isScript then GYTxBuildWitnessKey else GYTxBuildWitnessPlutusScript (GYBuildPlutusScriptInlined aStakeValidator) unitRedeemer -- This will check if we are able to register a stake credential without it's witness. registerStakeCredentialSteps :: GYCoinSelectionStrategy -> User -> Maybe GYScriptHash -> (String -> IO ()) -> Ctx -> IO () From 36bcb504a2bfc27c241def6e9f2fa9768624f39a Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 14:42:20 +0530 Subject: [PATCH 11/14] feat(#389): remove redundant patternsynonyms extension enabling, forward stakepoolids correctly --- src/GeniusYield/Imports.hs | 1 - src/GeniusYield/Test/Privnet/Examples/Gift.hs | 1 - src/GeniusYield/Test/Utils.hs | 2 -- src/GeniusYield/Transaction.hs | 3 +-- src/GeniusYield/TxBuilder/User.hs | 2 -- src/GeniusYield/Types/Credential.hs | 2 -- src/GeniusYield/Types/SlotConfig.hs | 2 -- 7 files changed, 1 insertion(+), 12 deletions(-) diff --git a/src/GeniusYield/Imports.hs b/src/GeniusYield/Imports.hs index ab85ea46..a694b1b4 100644 --- a/src/GeniusYield/Imports.hs +++ b/src/GeniusYield/Imports.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-orphans #-} {- | diff --git a/src/GeniusYield/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index 1ae212d8..04f23719 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} {- | Module : GeniusYield.Test.Privnet.Examples.Gift diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 300de808..55bf74be 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternSynonyms #-} - {- | Module : GeniusYield.Test.Utils Copyright : (c) 2023 GYELD GMBH diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index af67a18d..27fc919a 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -643,8 +643,7 @@ makeTransactionBodyAutoBalanceWrapper :: Word -> Int -> Either GYBuildTxError GYTxBody -makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp _ps utxos body changeAddr stakeDelegDeposits drepDelegDeposits nkeys numSkeletonOuts = do - let poolids = Set.empty -- TODO: This denotes the set of registered stake pools, that are being unregistered in this transaction. +makeTransactionBodyAutoBalanceWrapper collaterals ss eh pp poolids utxos body changeAddr stakeDelegDeposits drepDelegDeposits nkeys numSkeletonOuts = do let Ledger.ExUnits { exUnitsSteps = maxSteps , exUnitsMem = maxMemory diff --git a/src/GeniusYield/TxBuilder/User.hs b/src/GeniusYield/TxBuilder/User.hs index 6f64bb79..e3b04687 100644 --- a/src/GeniusYield/TxBuilder/User.hs +++ b/src/GeniusYield/TxBuilder/User.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternSynonyms #-} - module GeniusYield.TxBuilder.User ( User (..), UserCollateral (..), diff --git a/src/GeniusYield/Types/Credential.hs b/src/GeniusYield/Types/Credential.hs index 330cec2b..0dce0f79 100644 --- a/src/GeniusYield/Types/Credential.hs +++ b/src/GeniusYield/Types/Credential.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternSynonyms #-} - {- | Module : GeniusYield.Types.Credential Copyright : (c) 2023 GYELD GMBH diff --git a/src/GeniusYield/Types/SlotConfig.hs b/src/GeniusYield/Types/SlotConfig.hs index ef5257e0..16347dca 100644 --- a/src/GeniusYield/Types/SlotConfig.hs +++ b/src/GeniusYield/Types/SlotConfig.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternSynonyms #-} - {- | Module : GeniusYield.Types.SlotConfig Copyright : (c) 2023 GYELD GMBH From 69f94ff308a8f2dd55ccf7d653b364f561cc3bd5 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 14:53:36 +0530 Subject: [PATCH 12/14] feat(#389): remove usage gyinscript & gyinsimplescript --- src/GeniusYield/Test/Privnet/Examples/Gift.hs | 4 ++-- src/GeniusYield/Test/Privnet/Examples/Oracle.hs | 4 ++-- src/GeniusYield/Test/Privnet/Examples/Treat.hs | 2 +- src/GeniusYield/Transaction.hs | 4 ++-- src/GeniusYield/TxBuilder/Class.hs | 2 +- src/GeniusYield/TxBuilder/Common.hs | 2 +- src/GeniusYield/Types/TxCert/Internal.hs | 4 ++-- src/GeniusYield/Types/TxIn.hs | 12 ++++++------ src/GeniusYield/Types/TxWdrl.hs | 4 ++-- tests-privnet/GeniusYield/Test/Privnet/Blueprint.hs | 4 ++-- .../GeniusYield/Test/Privnet/SimpleScripts.hs | 2 +- .../GeniusYield/Test/Unified/BetRef/Operations.hs | 2 +- tests/GeniusYield/Test/FeeTracking.hs | 10 +++++----- tests/GeniusYield/Test/RefInput.hs | 2 +- 14 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/GeniusYield/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index 04f23719..d7753420 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -609,7 +609,7 @@ grabGifts validator = do { gyTxInTxOutRef = oref , gyTxInWitness = GYTxInWitnessScript - (GYInScript validator) + (GYBuildPlutusScriptInlined validator) (datumFromPlutus' od) unitRedeemer } @@ -638,7 +638,7 @@ grabGiftsRef ref validator = do { gyTxInTxOutRef = oref , gyTxInWitness = GYTxInWitnessScript - (GYInReference ref $ validatorToScript validator) + (GYBuildPlutusScriptReference ref $ validatorToScript validator) (datumFromPlutus' od) unitRedeemer } diff --git a/src/GeniusYield/Test/Privnet/Examples/Oracle.hs b/src/GeniusYield/Test/Privnet/Examples/Oracle.hs index a37c2647..873c418d 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Oracle.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Oracle.hs @@ -56,7 +56,7 @@ tests setup = { gyTxInTxOutRef = ref , gyTxInWitness = GYTxInWitnessScript - (GYInScript @PlutusV2 readOracleValidatorV2) + (GYBuildPlutusScriptInlined @PlutusV2 readOracleValidatorV2) (datumFromPlutusData (d :: ())) unitRedeemer } @@ -107,7 +107,7 @@ tests setup = { gyTxInTxOutRef = ref , gyTxInWitness = GYTxInWitnessScript - (GYInScript @PlutusV2 readOracleValidatorV2) + (GYBuildPlutusScriptInlined @PlutusV2 readOracleValidatorV2) (datumFromPlutusData (d :: ())) unitRedeemer } diff --git a/src/GeniusYield/Test/Privnet/Examples/Treat.hs b/src/GeniusYield/Test/Privnet/Examples/Treat.hs index ea074ecd..a8cd3d5e 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Treat.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Treat.hs @@ -108,7 +108,7 @@ grabTreats validator = do { gyTxInTxOutRef = oref , gyTxInWitness = GYTxInWitnessScript - (GYInScript validator) + (GYBuildPlutusScriptInlined validator) (datumFromPlutus' od) unitRedeemer } diff --git a/src/GeniusYield/Transaction.hs b/src/GeniusYield/Transaction.hs index 27fc919a..7a728107 100644 --- a/src/GeniusYield/Transaction.hs +++ b/src/GeniusYield/Transaction.hs @@ -443,8 +443,8 @@ finalizeGYBalancedTx where estimateKeyWitnessesFromNativeScripts acc (gyTxInWitness . gyTxInDet -> GYTxInWitnessSimpleScript gyInSS) = case gyInSS of - GYInSimpleScript s -> getTotalKeysInSimpleScript s <> acc - GYInReferenceSimpleScript _ s -> getTotalKeysInSimpleScript s <> acc + GYBuildSimpleScriptInlined s -> getTotalKeysInSimpleScript s <> acc + GYBuildSimpleScriptReference _ s -> getTotalKeysInSimpleScript s <> acc estimateKeyWitnessesFromNativeScripts acc _ = acc inRefs :: Api.TxInsReference ApiEra diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index 75857dbe..27df5f17 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -862,7 +862,7 @@ skeletonToRefScriptsORefs GYTxSkeleton {gytxIns} = go gytxIns [] go [] acc = acc go (gytxIn : rest) acc = case gyTxInWitness gytxIn of GYTxInWitnessScript gyInScript _ _ -> case gyInScript of - GYInReference oRef _ -> go rest (oRef : acc) + GYBuildPlutusScriptReference oRef _ -> go rest (oRef : acc) _anyOtherMatch -> go rest acc _anyOtherMatch -> go rest acc diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 246ec645..57c9b95a 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -248,7 +248,7 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk let refIns = gyTxSkeletonRefInsToList gytxRefIns - <> [r | GYTxIn {gyTxInWitness = GYTxInWitnessScript (GYInReference r _) _ _} <- gytxIns] + <> [r | GYTxIn {gyTxInWitness = GYTxInWitnessScript (GYBuildPlutusScriptReference r _) _ _} <- gytxIns] <> [r | GYBuildPlutusScript (GYBuildPlutusScriptReference r _) <- Map.keys gytxMint] allRefUtxos <- utxosAtTxOutRefs $ diff --git a/src/GeniusYield/Types/TxCert/Internal.hs b/src/GeniusYield/Types/TxCert/Internal.hs index 4ad036ce..a2f7d62f 100644 --- a/src/GeniusYield/Types/TxCert/Internal.hs +++ b/src/GeniusYield/Types/TxCert/Internal.hs @@ -18,13 +18,13 @@ module GeniusYield.Types.TxCert.Internal ( import Cardano.Api qualified as Api import Data.Functor ((<&>)) import GeniusYield.Imports ((&)) +import GeniusYield.Types.BuildScript import GeniusYield.Types.BuildWitness (GYTxBuildWitness (..), buildWitnessToApi) import GeniusYield.Types.Certificate import GeniusYield.Types.Credential (stakeCredentialToApi) import GeniusYield.Types.Era import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import GeniusYield.Types.Redeemer -import GeniusYield.Types.TxIn (GYInScript) {- | A transaction certificate. @@ -53,7 +53,7 @@ type GYTxCertWitness v = GYTxBuildWitness v pattern GYTxCertWitnessKey :: GYTxCertWitness v pattern GYTxCertWitnessKey = GYTxBuildWitnessKey -pattern GYTxCertWitnessScript :: GYInScript v -> GYRedeemer -> GYTxCertWitness v +pattern GYTxCertWitnessScript :: GYBuildPlutusScript v -> GYRedeemer -> GYTxCertWitness v pattern GYTxCertWitnessScript v r = GYTxBuildWitnessPlutusScript v r txCertToApi :: diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index 02d7164f..d272e731 100644 --- a/src/GeniusYield/Types/TxIn.hs +++ b/src/GeniusYield/Types/TxIn.hs @@ -47,9 +47,9 @@ data GYTxInWitness v = -- | Key witness without datum. GYTxInWitnessKey | -- | Script witness with associated script, datum, and redeemer. - GYTxInWitnessScript !(GYInScript v) !GYDatum !GYRedeemer + GYTxInWitnessScript !(GYBuildPlutusScript v) !GYDatum !GYRedeemer | -- | Simple script witness. - GYTxInWitnessSimpleScript !(GYInSimpleScript v) + GYTxInWitnessSimpleScript !(GYBuildSimpleScript v) deriving stock (Eq, Show) type GYInScript = GYBuildPlutusScript @@ -62,8 +62,8 @@ pattern GYInReference ref s = GYBuildPlutusScriptReference ref s {-# COMPLETE GYInScript, GYInReference #-} --- | Returns the 'PlutusVersion' of the given 'GYInScript'. -inScriptVersion :: GYInScript v -> PlutusVersion +-- | Returns the 'PlutusVersion' of the given 'GYBuildPlutusScript'. +inScriptVersion :: GYBuildPlutusScript v -> PlutusVersion inScriptVersion = buildPlutusScriptVersion type GYInSimpleScript = GYBuildSimpleScript @@ -91,8 +91,8 @@ txInToApi useInline (GYTxIn oref m) = (txOutRefToApi oref, Api.BuildTxWith $ f m f (GYTxInWitnessScript v d r) = Api.ScriptWitness Api.ScriptWitnessForSpending $ ( case v of - GYInScript s -> validatorToApiPlutusScriptWitness s - GYInReference ref s -> referenceScriptToApiPlutusScriptWitness ref s + GYBuildPlutusScriptInlined s -> validatorToApiPlutusScriptWitness s + GYBuildPlutusScriptReference ref s -> referenceScriptToApiPlutusScriptWitness ref s ) (if useInline then Api.InlineScriptDatum else Api.ScriptDatumForTxIn $ Just $ datumToApi' d) (redeemerToApi r) diff --git a/src/GeniusYield/Types/TxWdrl.hs b/src/GeniusYield/Types/TxWdrl.hs index e4c27e1f..0db69e73 100644 --- a/src/GeniusYield/Types/TxWdrl.hs +++ b/src/GeniusYield/Types/TxWdrl.hs @@ -17,10 +17,10 @@ import Cardano.Api qualified as Api import Cardano.Ledger.Coin qualified as Ledger import GeniusYield.Imports (Natural) import GeniusYield.Types.Address (GYStakeAddress, stakeAddressToApi) +import GeniusYield.Types.BuildScript import GeniusYield.Types.BuildWitness import GeniusYield.Types.Era import GeniusYield.Types.Redeemer -import GeniusYield.Types.TxIn (GYInScript) {- | Transaction withdrawal. @@ -39,7 +39,7 @@ type GYTxWdrlWitness v = GYTxBuildWitness v pattern GYTxWdrlWitnessKey :: GYTxWdrlWitness v pattern GYTxWdrlWitnessKey = GYTxBuildWitnessKey -pattern GYTxWdrlWitnessScript :: GYInScript v -> GYRedeemer -> GYTxWdrlWitness v +pattern GYTxWdrlWitnessScript :: GYBuildPlutusScript v -> GYRedeemer -> GYTxWdrlWitness v pattern GYTxWdrlWitnessScript v r = GYTxBuildWitnessPlutusScript v r txWdrlToApi :: diff --git a/tests-privnet/GeniusYield/Test/Privnet/Blueprint.hs b/tests-privnet/GeniusYield/Test/Privnet/Blueprint.hs index 506b4088..ef3f187a 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Blueprint.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Blueprint.hs @@ -41,10 +41,10 @@ blueprintTests setup = (\e -> if isTxBodyErrorAutoBalance e then pure () else throwError e) $ asUser user $ do - void $ buildTxBody $ mustHaveInput @'PlutusV3 $ GYTxIn oref (GYTxInWitnessScript (GYInScript val) dat unsatRedeemer) + void $ buildTxBody $ mustHaveInput @'PlutusV3 $ GYTxIn oref (GYTxInWitnessScript (GYBuildPlutusScriptInlined val) dat unsatRedeemer) lg "Successfully failed to consume from blueprint script for unsatisfying redeemer" tid <- asUser user $ do - txBody <- buildTxBody $ mustHaveInput @'PlutusV3 $ GYTxIn oref (GYTxInWitnessScript (GYInScript val) dat satRedeemer) + txBody <- buildTxBody $ mustHaveInput @'PlutusV3 $ GYTxIn oref (GYTxInWitnessScript (GYBuildPlutusScriptInlined val) dat satRedeemer) signAndSubmitConfirmed txBody lg $ "Successfully consumed from blueprint script, with tx id: " <> show tid ] diff --git a/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs b/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs index d0e1eb7f..b3b972bd 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/SimpleScripts.hs @@ -44,6 +44,6 @@ exerciseASimpleScript ctx info toUseRefScript = do toConsumeUtxo <- ctxRun ctx fundUser $ utxoAtTxOutRef' toConsume assertEqual "Reference script must be equal to actual script" (Just $ GYSimpleScript multiSigSimpleScript) (utxoRefScript toConsumeUtxo) txIdConsume <- ctxRun ctx fundUser $ do - txBodyConsume <- buildTxBody $ mustHaveInput @'PlutusV2 $ GYTxIn toConsume (GYTxInWitnessSimpleScript $ if toUseRefScript then GYInReferenceSimpleScript toConsume multiSigSimpleScript else GYInSimpleScript multiSigSimpleScript) + txBodyConsume <- buildTxBody $ mustHaveInput @'PlutusV2 $ GYTxIn toConsume (GYTxInWitnessSimpleScript $ if toUseRefScript then GYBuildSimpleScriptReference toConsume multiSigSimpleScript else GYBuildSimpleScriptInlined multiSigSimpleScript) submitTxBodyConfirmed txBodyConsume $ userPaymentSKey <$> [user1, user2, user3] info $ "Successfully consumed the simple script, with tx id: " <> show txIdConsume diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs index 7b918387..eee80026 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs @@ -140,7 +140,7 @@ input brp refScript inputRef dat red = { gyTxInTxOutRef = inputRef , gyTxInWitness = GYTxInWitnessScript - (GYInReference refScript $ validatorToScript $ mkBetRefValidator brp) + (GYBuildPlutusScriptReference refScript $ validatorToScript $ mkBetRefValidator brp) (datumFromPlutusData dat) (redeemerFromPlutusData red) } diff --git a/tests/GeniusYield/Test/FeeTracking.hs b/tests/GeniusYield/Test/FeeTracking.hs index 5650206d..5e438919 100644 --- a/tests/GeniusYield/Test/FeeTracking.hs +++ b/tests/GeniusYield/Test/FeeTracking.hs @@ -64,7 +64,7 @@ sendAndConsume Wallets {w1, w2} amt = withWalletBalancesCheckSimple [w1 := value txBody <- buildTxBody @PlutusV1 . mustHaveInput $ GYTxIn - { gyTxInWitness = GYTxInWitnessScript (GYInScript gyAlwaysSucceedsValidator) unitDatum unitRedeemer + { gyTxInWitness = GYTxInWitnessScript (GYBuildPlutusScriptInlined gyAlwaysSucceedsValidator) unitDatum unitRedeemer , gyTxInTxOutRef = txOutRefFromTuple (txId, 0) } signAndSubmitConfirmed_ txBody @@ -81,7 +81,7 @@ sendAndContinue Wallets {w1, w2} amt = withWalletBalancesCheckSimple [w1 := valu mconcat [ mustHaveInput $ GYTxIn - { gyTxInWitness = GYTxInWitnessScript (GYInScript gyAlwaysSucceedsValidator) unitDatum unitRedeemer + { gyTxInWitness = GYTxInWitnessScript (GYBuildPlutusScriptInlined gyAlwaysSucceedsValidator) unitDatum unitRedeemer , gyTxInTxOutRef = txOutRefFromTuple (txId, 0) } , mustHaveOutput $ mkGYTxOut target amt unitDatum @@ -97,7 +97,7 @@ selfConsume Wallets {w1} amt = withWalletBalancesCheckSimple [w1 := mempty] $ do consumeBody <- buildTxBody @PlutusV1 . mustHaveInput $ GYTxIn - { gyTxInWitness = GYTxInWitnessScript (GYInScript gyAlwaysSucceedsValidator) unitDatum unitRedeemer + { gyTxInWitness = GYTxInWitnessScript (GYBuildPlutusScriptInlined gyAlwaysSucceedsValidator) unitDatum unitRedeemer , gyTxInTxOutRef = txOutRefFromTuple (txId, 0) } signAndSubmitConfirmed_ consumeBody @@ -113,7 +113,7 @@ selfContinue Wallets {w1} amt = withWalletBalancesCheckSimple [w1 := valueNegate mconcat [ mustHaveInput $ GYTxIn - { gyTxInWitness = GYTxInWitnessScript (GYInScript gyAlwaysSucceedsValidator) unitDatum unitRedeemer + { gyTxInWitness = GYTxInWitnessScript (GYBuildPlutusScriptInlined gyAlwaysSucceedsValidator) unitDatum unitRedeemer , gyTxInTxOutRef = txOutRefFromTuple (txId, 0) } , mustHaveOutput $ mkGYTxOut target amt unitDatum @@ -134,7 +134,7 @@ selfPartialConsume lovelaceConf TestInfo {testWallets = Wallets {w1}, testGoldAs mconcat [ mustHaveInput $ GYTxIn - { gyTxInWitness = GYTxInWitnessScript (GYInScript gyAlwaysSucceedsValidator) unitDatum unitRedeemer + { gyTxInWitness = GYTxInWitnessScript (GYBuildPlutusScriptInlined gyAlwaysSucceedsValidator) unitDatum unitRedeemer , gyTxInTxOutRef = txOutRefFromTuple (txId, 0) } , mustHaveOutput $ mkGYTxOut target partialAmt unitDatum diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 80545c43..26b92920 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -52,7 +52,7 @@ guessRefInputRun refInputORef consumeRef guess = do { gyTxInTxOutRef = consumeRef , gyTxInWitness = GYTxInWitnessScript - (GYInScript gyGuessRefInputDatumValidator) + (GYBuildPlutusScriptInlined gyGuessRefInputDatumValidator) (datumFromPlutusData ()) (redeemerFromPlutusData redeemer) } From ca906589af6aadf160c3acab6e0a98e24e594df8 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 15:28:09 +0530 Subject: [PATCH 13/14] fix(#389): update refIns variable to account for all reference inputs --- src/GeniusYield/TxBuilder/Common.hs | 35 ++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 57c9b95a..19a985b3 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -35,6 +35,7 @@ import Data.List (nubBy) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map +import Data.Maybe (maybeToList) import Data.Ratio ((%)) import Data.Set qualified as Set import GeniusYield.Imports @@ -46,6 +47,7 @@ import GeniusYield.Transaction.Common ( import GeniusYield.TxBuilder.Errors import GeniusYield.TxBuilder.Query.Class import GeniusYield.Types +import GeniusYield.Types.TxCert.Internal (GYTxCert (..)) ------------------------------------------------------------------------------- -- Transaction skeleton @@ -246,10 +248,33 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk , [(mp, redeemer) | (mp, (_, redeemer)) <- itoList gytxMint] ) - let refIns = + let extractReferenceFromWitness :: GYTxBuildWitness v -> Maybe GYTxOutRef + extractReferenceFromWitness (GYTxBuildWitnessSimpleScript (GYBuildSimpleScriptReference r _)) = Just r + extractReferenceFromWitness (GYTxBuildWitnessPlutusScript (GYBuildPlutusScriptReference r _) _) = Just r + extractReferenceFromWitness _anyOther = Nothing + gytxVotingProcedures' = case gytxVotingProcedures of GYTxSkeletonVotingProceduresNone -> mempty; GYTxSkeletonVotingProcedures vp -> vp + gytxProposalProcedures' = case gytxProposalProcedures of GYTxSkeletonProposalProceduresNone -> mempty; GYTxSkeletonProposalProcedures pps -> pps + refIns = gyTxSkeletonRefInsToList gytxRefIns - <> [r | GYTxIn {gyTxInWitness = GYTxInWitnessScript (GYBuildPlutusScriptReference r _) _ _} <- gytxIns] - <> [r | GYBuildPlutusScript (GYBuildPlutusScriptReference r _) <- Map.keys gytxMint] + <> [ r + | GYTxIn {gyTxInWitness = wit} <- gytxIns + , r <- case wit of + GYTxInWitnessScript (GYBuildPlutusScriptReference r _) _ _ -> [r] + GYTxInWitnessSimpleScript (GYBuildSimpleScriptReference r _) -> [r] + _anyOther -> [] + ] + <> [ r + | wit <- Map.keys gytxMint + , r <- case wit of + GYBuildPlutusScript (GYBuildPlutusScriptReference r _) -> [r] + GYBuildSimpleScript (GYBuildSimpleScriptReference r _) -> [r] + _anyOther -> [] + ] + <> [r | wdrl <- gytxWdrls, r <- maybeToList (extractReferenceFromWitness $ gyTxWdrlWitness wdrl)] + <> [r | cert <- gytxCerts, r <- maybeToList (gyTxCertWitness cert >>= extractReferenceFromWitness)] + <> [r | votingWit <- map fst (Map.elems gytxVotingProcedures'), r <- maybeToList (extractReferenceFromWitness votingWit)] + <> [r | propProc <- gytxProposalProcedures', r <- maybeToList (extractReferenceFromWitness $ snd propProc)] + allRefUtxos <- utxosAtTxOutRefs $ (gyTxInTxOutRef <$> gytxIns) @@ -312,8 +337,8 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk gytxInvalidAfter gytxSigs gytxMetadata - (case gytxVotingProcedures of GYTxSkeletonVotingProceduresNone -> mempty; GYTxSkeletonVotingProcedures vp -> vp) - (case gytxProposalProcedures of GYTxSkeletonProposalProceduresNone -> mempty; GYTxSkeletonProposalProcedures pps -> pps) + gytxVotingProcedures' + gytxProposalProcedures' go :: GYUTxOs -> GYTxBuildResult -> [GYTxSkeleton v] -> m (Either GYBuildTxError GYTxBuildResult) go _ acc [] = pure $ Right $ reverseResult acc From e3fabc0d60d634273edc7303359e11567aa82296 Mon Sep 17 00:00:00 2001 From: sourabhxyz Date: Tue, 14 Jan 2025 16:00:24 +0530 Subject: [PATCH 14/14] feat(#389): filter txIns from refIns --- src/GeniusYield/TxBuilder/Common.hs | 40 +++++++++++++++-------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/GeniusYield/TxBuilder/Common.hs b/src/GeniusYield/TxBuilder/Common.hs index 19a985b3..08edb677 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -255,25 +255,27 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk gytxVotingProcedures' = case gytxVotingProcedures of GYTxSkeletonVotingProceduresNone -> mempty; GYTxSkeletonVotingProcedures vp -> vp gytxProposalProcedures' = case gytxProposalProcedures of GYTxSkeletonProposalProceduresNone -> mempty; GYTxSkeletonProposalProcedures pps -> pps refIns = - gyTxSkeletonRefInsToList gytxRefIns - <> [ r - | GYTxIn {gyTxInWitness = wit} <- gytxIns - , r <- case wit of - GYTxInWitnessScript (GYBuildPlutusScriptReference r _) _ _ -> [r] - GYTxInWitnessSimpleScript (GYBuildSimpleScriptReference r _) -> [r] - _anyOther -> [] - ] - <> [ r - | wit <- Map.keys gytxMint - , r <- case wit of - GYBuildPlutusScript (GYBuildPlutusScriptReference r _) -> [r] - GYBuildSimpleScript (GYBuildSimpleScriptReference r _) -> [r] - _anyOther -> [] - ] - <> [r | wdrl <- gytxWdrls, r <- maybeToList (extractReferenceFromWitness $ gyTxWdrlWitness wdrl)] - <> [r | cert <- gytxCerts, r <- maybeToList (gyTxCertWitness cert >>= extractReferenceFromWitness)] - <> [r | votingWit <- map fst (Map.elems gytxVotingProcedures'), r <- maybeToList (extractReferenceFromWitness votingWit)] - <> [r | propProc <- gytxProposalProcedures', r <- maybeToList (extractReferenceFromWitness $ snd propProc)] + -- We want to filter out the references that are already in the txIns. + filter (\oref -> all (\txIn -> gyTxInTxOutRef txIn /= oref) gytxIns) $ + gyTxSkeletonRefInsToList gytxRefIns + <> [ r + | GYTxIn {gyTxInWitness = wit} <- gytxIns + , r <- case wit of + GYTxInWitnessScript (GYBuildPlutusScriptReference r _) _ _ -> [r] + GYTxInWitnessSimpleScript (GYBuildSimpleScriptReference r _) -> [r] + _anyOther -> [] + ] + <> [ r + | wit <- Map.keys gytxMint + , r <- case wit of + GYBuildPlutusScript (GYBuildPlutusScriptReference r _) -> [r] + GYBuildSimpleScript (GYBuildSimpleScriptReference r _) -> [r] + _anyOther -> [] + ] + <> [r | wdrl <- gytxWdrls, r <- maybeToList (extractReferenceFromWitness $ gyTxWdrlWitness wdrl)] + <> [r | cert <- gytxCerts, r <- maybeToList (gyTxCertWitness cert >>= extractReferenceFromWitness)] + <> [r | votingWit <- map fst (Map.elems gytxVotingProcedures'), r <- maybeToList (extractReferenceFromWitness votingWit)] + <> [r | propProc <- gytxProposalProcedures', r <- maybeToList (extractReferenceFromWitness $ snd propProc)] allRefUtxos <- utxosAtTxOutRefs $