diff --git a/CHANGELOG.md b/CHANGELOG.md index 91bceb70..660e85e4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,9 @@ * 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. +* Adds support for governance actions, namely proposal procedures & voting procedures. ## 0.7.0 diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 0845c5e7..c96c2aee 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 @@ -371,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/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/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/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/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index 1ae212d8..d7753420 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 @@ -610,7 +609,7 @@ grabGifts validator = do { gyTxInTxOutRef = oref , gyTxInWitness = GYTxInWitnessScript - (GYInScript validator) + (GYBuildPlutusScriptInlined validator) (datumFromPlutus' od) unitRedeemer } @@ -639,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/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/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/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index bfa72152..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 @@ -218,7 +216,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 c2a15734..7a728107 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, @@ -88,6 +89,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'), @@ -104,7 +106,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 +151,7 @@ buildUnsignedTxBody :: -- | reference inputs GYUTxOs -> -- | minted values - Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -> + Maybe (GYValue, [(GYBuildScript v, GYRedeemer)]) -> -- | withdrawals [GYTxWdrl v] -> -- | certificates @@ -159,13 +160,15 @@ buildUnsignedTxBody :: Maybe GYSlot -> 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 = 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 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 @@ -226,6 +229,8 @@ buildUnsignedTxBody env cstrat insOld outsOld refIns mmint wdrls certs lb ub sig , gybtxSigners = signers , gybtxRefIns = refIns , gybtxMetadata = mbTxMetadata + , gybtxVotingProcedures = vps + , gybtxProposalProcedures = pps } (length outsOld) @@ -247,11 +252,15 @@ balanceTxStep :: (HasCallStack, MonadRandom m) => GYBuildTxEnv -> -- | minting - Maybe (GYValue, [(GYMintScript v, GYRedeemer)]) -> + Maybe (GYValue, [(GYBuildScript v, GYRedeemer)]) -> -- | withdrawals [GYTxWdrl v] -> -- | certificates [GYTxCert' v] -> + -- | voting procedures + GYTxVotingProcedures v -> + -- | proposal procedures + [(GYProposalProcedurePB, GYTxBuildWitness v)] -> -- | transaction inputs [GYTxInDetailed v] -> -- | transaction outputs @@ -272,12 +281,14 @@ balanceTxStep mmint wdrls certs + vps + pps 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 @@ -307,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 @@ -345,10 +358,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 @@ -374,6 +388,8 @@ finalizeGYBalancedTx , gybtxSigners = signers , gybtxRefIns = utxosRefInputs , gybtxMetadata = mbTxMetadata + , gybtxVotingProcedures = vps + , gybtxProposalProcedures = pps } = makeTransactionBodyAutoBalanceWrapper collaterals @@ -394,8 +410,10 @@ 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 = 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 <> Set.toList signers where @@ -404,8 +422,14 @@ 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 + + propProcToPKH GYProposalProcedurePB {propProcPBReturnAddr} = stakeAddressToCredential propProcPBReturnAddr & preferCByKey countUnique :: Ord a => [a] -> Int countUnique = Set.size . Set.fromList @@ -419,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 @@ -477,10 +501,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 +557,45 @@ 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 + 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 = Api.TxBodyContent @@ -553,10 +619,10 @@ finalizeGYBalancedTx , Api.txUpdateProposal = Api.TxUpdateProposalNone , Api.txMintValue = mint , Api.txScriptValidity = Api.TxScriptValidityNone - , Api.txProposalProcedures = Nothing - , Api.txVotingProcedures = Nothing + , Api.txProposalProcedures = pps' + , 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. @@ -577,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/Transaction/Common.hs b/src/GeniusYield/Transaction/Common.hs index 1e54fea2..fe84f439 100644 --- a/src/GeniusYield/Transaction/Common.hs +++ b/src/GeniusYield/Transaction/Common.hs @@ -22,7 +22,10 @@ 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.BuildWitness import GeniusYield.Types.Era +import GeniusYield.Types.Governance (GYProposalProcedurePB, GYTxVotingProcedures) import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) import GeniusYield.Types.PubKeyHash import GeniusYield.Types.Redeemer @@ -46,7 +49,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 +57,8 @@ data GYBalancedTx v = GYBalancedTx , gybtxSigners :: !(Set GYPubKeyHash) , 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/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index 63673e7f..27df5f17 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -85,6 +85,9 @@ module GeniusYield.TxBuilder.Class ( mustHaveOutput, mustHaveOptionalOutput, mustHaveTxMetadata, + mustHaveVotingProcedures, + mustHaveProposalProcedure, + mustHaveProposalProcedures, mustMint, mustHaveWithdrawal, mustHaveCertificate, @@ -129,7 +132,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 +820,16 @@ 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} + +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)} @@ -851,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 298a958d..08edb677 100644 --- a/src/GeniusYield/TxBuilder/Common.hs +++ b/src/GeniusYield/TxBuilder/Common.hs @@ -8,6 +8,8 @@ Stability : develop module GeniusYield.TxBuilder.Common ( GYTxSkeleton (..), GYTxSkeletonRefIns (..), + GYTxSkeletonVotingProcedures (..), + GYTxSkeletonProposalProcedures (..), emptyGYTxSkeleton, gyTxSkeletonRefInsToList, gyTxSkeletonRefInsSet, @@ -33,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 @@ -44,7 +47,7 @@ import GeniusYield.Transaction.Common ( import GeniusYield.TxBuilder.Errors import GeniusYield.TxBuilder.Query.Class import GeniusYield.Types -import GeniusYield.Types.ProtocolParameters (ApiProtocolParameters) +import GeniusYield.Types.TxCert.Internal (GYTxCert (..)) ------------------------------------------------------------------------------- -- Transaction skeleton @@ -61,16 +64,44 @@ 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) + , gytxProposalProcedures :: !(GYTxSkeletonProposalProcedures 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 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 @@ -104,6 +135,8 @@ emptyGYTxSkeleton = , gytxInvalidBefore = Nothing , gytxInvalidAfter = Nothing , gytxMetadata = Nothing + , gytxVotingProcedures = GYTxSkeletonVotingProceduresNone + , gytxProposalProcedures = GYTxSkeletonProposalProceduresNone } instance Semigroup (GYTxSkeleton v) where @@ -119,6 +152,8 @@ 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 + , gytxProposalProcedures = gytxProposalProcedures x <> gytxProposalProcedures y } where -- we keep only one input per utxo to spend @@ -204,7 +239,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 = @@ -213,10 +248,35 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk , [(mp, redeemer) | (mp, (_, redeemer)) <- itoList gytxMint] ) - let refIns = - gyTxSkeletonRefInsToList gytxRefIns - <> [r | GYTxIn {gyTxInWitness = GYTxInWitnessScript (GYInReference r _) _ _} <- gytxIns] - <> [r | GYMintReference r _ <- Map.keys gytxMint] + 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 = + -- 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 $ (gyTxInTxOutRef <$> gytxIns) @@ -279,6 +339,8 @@ buildTxCore ss eh pp ps cstrat ownUtxoUpdateF addrs change reservedCollateral sk gytxInvalidAfter gytxSigs gytxMetadata + gytxVotingProcedures' + gytxProposalProcedures' go :: GYUTxOs -> GYTxBuildResult -> [GYTxSkeleton v] -> m (Either GYBuildTxError GYTxBuildResult) go _ acc [] = pure $ Right $ reverseResult acc @@ -301,7 +363,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..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 (..), @@ -7,6 +5,7 @@ module GeniusYield.TxBuilder.User ( userPkh, userPaymentPkh, userStakePkh, + userStakeAddress, userVKey, userPaymentVKey, userPaymentSKey', @@ -21,9 +20,9 @@ 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) +import GeniusYield.Types.Address (GYAddress, GYStakeAddress, stakeAddressFromCredential) 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) @@ -74,6 +73,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 9e962445..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,10 +159,13 @@ 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 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 +173,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 +185,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/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/BuildScript.hs b/src/GeniusYield/Types/BuildScript.hs new file mode 100644 index 00000000..beda9514 --- /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 :: 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 :: GYBuildScript v -> Api.PolicyId +mintingPolicyApiIdFromWitness = mintingPolicyIdToApi . mintingPolicyIdFromWitness 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/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/Governance.hs b/src/GeniusYield/Types/Governance.hs new file mode 100644 index 00000000..389763ac --- /dev/null +++ b/src/GeniusYield/Types/Governance.hs @@ -0,0 +1,227 @@ +{- | +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, + GYProposalProcedurePB (..), + GYProposalProcedure (..), + completeProposalProcedure, + propProcToLedger, + GYConstitution (..), + constitutionToLedger, + GYGovAction (..), + govActionToLedger, +) 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.Set qualified as Set +import Data.Word (Word16) +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 + +-- | 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)) + +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 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/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/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/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 diff --git a/src/GeniusYield/Types/TxCert.hs b/src/GeniusYield/Types/TxCert.hs index 4093ace6..b4e137d2 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, @@ -23,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) @@ -33,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: @@ -42,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: @@ -56,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: @@ -65,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: @@ -76,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: @@ -92,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: @@ -105,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: @@ -116,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: @@ -131,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/src/GeniusYield/Types/TxCert/Internal.hs b/src/GeniusYield/Types/TxCert/Internal.hs index 296cf732..a2f7d62f 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.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.Script {- | 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 :: GYBuildPlutusScript 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'))) diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index 9fd66a0b..d272e731 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 @@ -44,44 +47,33 @@ 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) -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 -deriving instance Show (GYInScript v) +pattern GYInReference :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYScript u -> GYBuildPlutusScript u +pattern GYInReference ref s = GYBuildPlutusScriptReference ref s -instance Eq (GYInScript v) where - GYInReference ref1 script1 == GYInReference ref2 script2 = ref1 == ref2 && script1 == script2 - GYInScript v1 == GYInScript v2 = defaultEq v1 v2 - _ == _ = False +{-# COMPLETE GYInScript, GYInReference #-} -data GYInSimpleScript (u :: PlutusVersion) where - GYInSimpleScript :: !GYSimpleScript -> GYInSimpleScript u - GYInReferenceSimpleScript :: v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !GYSimpleScript -> GYInSimpleScript v +-- | Returns the 'PlutusVersion' of the given 'GYBuildPlutusScript'. +inScriptVersion :: GYBuildPlutusScript v -> PlutusVersion +inScriptVersion = buildPlutusScriptVersion -deriving instance Show (GYInSimpleScript v) +type GYInSimpleScript = GYBuildSimpleScript -instance Eq (GYInSimpleScript v) where - GYInSimpleScript s1 == GYInSimpleScript s2 = s1 == s2 - GYInReferenceSimpleScript ref1 s1 == GYInReferenceSimpleScript ref2 s2 = ref1 == ref2 && s1 == s2 - _ == _ = False +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 + +{-# COMPLETE GYInSimpleScript, GYInReferenceSimpleScript #-} {- | @@ -99,14 +91,11 @@ 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) (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 diff --git a/src/GeniusYield/Types/TxWdrl.hs b/src/GeniusYield/Types/TxWdrl.hs index d853cbb3..0db69e73 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.BuildScript +import GeniusYield.Types.BuildWitness import GeniusYield.Types.Era import GeniusYield.Types.Redeemer -import GeniusYield.Types.Script {- | 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 :: GYBuildPlutusScript 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/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/Committee.hs b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs index b9b45feb..fbfc03cb 100644 --- a/tests-privnet/GeniusYield/Test/Privnet/Committee.hs +++ b/tests-privnet/GeniusYield/Test/Privnet/Committee.hs @@ -1,13 +1,10 @@ module GeniusYield.Test.Privnet.Committee ( committeeTests, + delegateHotKey, ) 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 @@ -23,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 -> 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 - coldCred = GYCredentialByKey $ verificationKeyHash $ getVerificationKey coldKey + let coldKey = ctxCommittee ctx & ctxCommitteeMembers & Map.toList & (!! ix) & fst + 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) - let anchor = GYAnchor (unsafeTextToUrl "https://www.geniusyield.io") (hashAnchorData "we are awesome") +exerciseCommittee :: Ctx -> (String -> IO ()) -> IO () +exerciseCommittee ctx info = do + let fundUser = ctxUserF ctx + (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" 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..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 @@ -40,9 +40,9 @@ 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 + 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 new file mode 100644 index 00000000..a5e74903 --- /dev/null +++ b/tests-privnet/GeniusYield/Test/Privnet/Gov.hs @@ -0,0 +1,56 @@ +module GeniusYield.Test.Privnet.Gov ( + govTests, +) where + +import Control.Lens ((^.)) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust) +import GeniusYield.Test.Privnet.Committee +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 + (_, hotSKey) <- delegateHotKey ctx info newUser 1 + 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 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-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs b/tests-privnet/GeniusYield/Test/Privnet/Stake/Utils.hs index f23d4587..270361d0 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 (GYBuildPlutusScriptInlined 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 (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 () 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 ] 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/GYTxBody.hs b/tests/GeniusYield/Test/GYTxBody.hs index d3267c11..506a725f 100644 --- a/tests/GeniusYield/Test/GYTxBody.hs +++ b/tests/GeniusYield/Test/GYTxBody.hs @@ -151,6 +151,8 @@ balanceTxStepTests = Nothing [] [] + mempty + mempty [] [] GYRandomImproveMultiAsset @@ -163,6 +165,8 @@ balanceTxStepTests = Nothing [] [] + mempty + mempty [] [] GYRandomImproveMultiAsset @@ -175,6 +179,8 @@ balanceTxStepTests = (Just (valueSingleton (mockAsset "A") 100, [])) [] [] + mempty + mempty [] [] GYRandomImproveMultiAsset diff --git a/tests/GeniusYield/Test/GYTxSkeleton.hs b/tests/GeniusYield/Test/GYTxSkeleton.hs index bb39d20b..7a798c2d 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 @@ -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" 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) }