diff --git a/cabal.project b/cabal.project index f3c414a9..c6515b08 100644 --- a/cabal.project +++ b/cabal.project @@ -23,9 +23,9 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2025-04-16T16:04:13Z - , cardano-haskell-packages 2025-05-16T15:25:35Z - + , hackage.haskell.org 2025-06-22T20:18:27Z + , cardano-haskell-packages 2025-07-14T17:31:29Z + -- We never, ever, want this. write-ghc-environment-files: never @@ -47,12 +47,12 @@ package cardano-crypto-praos flags: -external-libsodium-vrf constraints: - cardano-api == 10.16.1.0 + cardano-api == 10.17.2.0 source-repository-package type: git location: https://github.com/intersectMBO/cardano-node-emulator - tag: 6d65996418d2b00fa791407ec47e2fe77c208790 + tag: origin/mm/update-prot-version subdir: plutus-script-utils plutus-ledger diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 1c062b3c..7ad9df60 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -17,7 +17,6 @@ library Cooked.Attack.AddToken Cooked.Attack.DatumHijacking Cooked.Attack.DoubleSat - Cooked.Attack.DupToken Cooked.InitialDistribution Cooked.Ltl Cooked.MockChain @@ -26,7 +25,9 @@ library Cooked.MockChain.BlockChain Cooked.MockChain.Direct Cooked.MockChain.GenerateTx + Cooked.MockChain.GenerateTx.Anchor Cooked.MockChain.GenerateTx.Body + Cooked.MockChain.GenerateTx.Certificate Cooked.MockChain.GenerateTx.Collateral Cooked.MockChain.GenerateTx.Common Cooked.MockChain.GenerateTx.Input @@ -51,15 +52,18 @@ library Cooked.Pretty.Skeleton Cooked.ShowBS Cooked.Skeleton + Cooked.Skeleton.Anchor + Cooked.Skeleton.Certificate Cooked.Skeleton.Datum + Cooked.Skeleton.Families Cooked.Skeleton.Label Cooked.Skeleton.Mint Cooked.Skeleton.Option Cooked.Skeleton.Output - Cooked.Skeleton.Payable Cooked.Skeleton.Proposal Cooked.Skeleton.Redeemer - Cooked.Skeleton.ReferenceScript + Cooked.Skeleton.User + Cooked.Skeleton.Value Cooked.Skeleton.Withdrawal Cooked.Tweak Cooked.Tweak.Common @@ -169,6 +173,7 @@ test-suite spec Spec.Attack.DupToken Spec.Balancing Spec.BasicUsage + Spec.Certificates Spec.InitialDistribution Spec.InlineDatums Spec.Ltl diff --git a/flake.lock b/flake.lock index 58dc1784..6d71ef55 100644 --- a/flake.lock +++ b/flake.lock @@ -57,11 +57,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1747919418, - "narHash": "sha256-LHQHk4GNuzhqnnO6JxGOXZPpYGtex5oc6/KxAYV0O8I=", + "lastModified": 1753197807, + "narHash": "sha256-tnnc0O4d/jq12nP2ulFuzXO2aF+oUR+G+7uByn9WvjQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "053bdd80dd362baf11a798e11a57d511b1641478", + "rev": "666cb2244959dcae7ff177fe8f8aca2470626d81", "type": "github" }, "original": { @@ -79,11 +79,11 @@ ] }, "locked": { - "lastModified": 1747372754, - "narHash": "sha256-2Y53NGIX2vxfie1rOW0Qb86vjRZ7ngizoo+bnXU9D9k=", + "lastModified": 1750779888, + "narHash": "sha256-wibppH3g/E2lxU43ZQHC5yA/7kIKLGxVEnsnVK1BtRg=", "owner": "cachix", "repo": "pre-commit-hooks.nix", - "rev": "80479b6ec16fefd9c1db3ea13aeb038c60530f46", + "rev": "16ec914f6fb6f599ce988427d9d94efddf25fe6d", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index a27b2a50..0a6e651a 100644 --- a/flake.nix +++ b/flake.nix @@ -66,7 +66,8 @@ LD_LIBRARY_PATH = pkgs.lib.strings.makeLibraryPath [ pkgs.xz pkgs.zlib - pkgs.openssl_3_4 + pkgs.lmdb + pkgs.openssl_3_5 pkgs.postgresql # For cardano-node-emulator pkgs.openldap # For freer-extras‽ pkgs.libsodium diff --git a/src/Cooked.hs b/src/Cooked.hs index 7495067e..c469e9b7 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -1,10 +1,16 @@ -- | Re-exports the entirety of the library, which is always eventually necessary -- when writing large test-suites. -module Cooked (module X) where +module Cooked + ( module X, + Ltl (..), + MonadModal (..), + ltlDelay, + ) +where import Cooked.Attack as X import Cooked.InitialDistribution as X -import Cooked.Ltl as X (Ltl (..), MonadModal (..), ltlDelay) +import Cooked.Ltl (Ltl (..), MonadModal (..), ltlDelay) import Cooked.MockChain as X import Cooked.Pretty as X import Cooked.ShowBS as X diff --git a/src/Cooked/Attack.hs b/src/Cooked/Attack.hs index bfaca722..dd8078ba 100644 --- a/src/Cooked/Attack.hs +++ b/src/Cooked/Attack.hs @@ -15,4 +15,3 @@ module Cooked.Attack (module X) where import Cooked.Attack.AddToken as X import Cooked.Attack.DatumHijacking as X import Cooked.Attack.DoubleSat as X -import Cooked.Attack.DupToken as X diff --git a/src/Cooked/Attack/AddToken.hs b/src/Cooked/Attack/AddToken.hs index 403c8b14..b7db1a12 100644 --- a/src/Cooked/Attack/AddToken.hs +++ b/src/Cooked/Attack/AddToken.hs @@ -1,53 +1,95 @@ --- | This module provides an automated attack to mint and give extra tokens to a --- certain wallet. -module Cooked.Attack.AddToken (addTokenAttack, AddTokenLbl (..)) where +-- | This module provides two automated attacks to mint and give extra tokens to +-- a certain target. +module Cooked.Attack.AddToken + ( addTokenAttack, + AddTokenLbl (..), + dupTokenAttack, + DupTokenLbl (..), + ) +where import Control.Monad import Cooked.Pretty import Cooked.Skeleton import Cooked.Tweak +import Data.List.NonEmpty qualified as NEList +import Data.Map qualified as Map +import Data.Map.NonEmpty qualified as NEMap import Optics.Core -import Plutus.Script.Utils.Scripts qualified as Script +import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api -import PlutusTx.AssocMap qualified as PMap +import PlutusTx.Numeric qualified as PlutusTx import Prettyprinter qualified as PP +import Test.QuickCheck.Modifiers --- | This attack adds extra tokens, depending on the minting policy. It is --- different from the 'Cooked.Attack.DupToken.dupTokenAttack' in that it does --- not merely try to increase the amount of tokens minted: It tries to mint --- tokens of asset classes that were not necessarily present on the unmodified --- transaction. +-- | This attack adds extra tokens of any kind for minting policies already +-- present in the minted value. The additional minted value is redirected to a +-- certain owner in a dedicated output. -- -- This attack adds an 'AddTokenLbl' label. addTokenAttack :: - (MonadTweak m, OwnerConstrs o) => + (MonadTweak m, IsTxSkelOutAllowedOwner o) => -- | For each policy that occurs in some 'Mint' constraint, return a list of -- token names together with how many tokens with that name should be minted. - (Script.Versioned Script.MintingPolicy -> [(Api.TokenName, Integer)]) -> + (VScript -> [(Api.TokenName, Integer)]) -> -- | The wallet of the attacker where extra tokens will be paid to o -> m Api.Value addTokenAttack extraTokens attacker = do - oldMintsList <- viewTweak $ txSkelMintsL % txSkelMintsListI - let (newMintsList, totalIncrement) = - foldl - ( \(newMs, addVal) (Mint mp@(Script.toVersioned @Script.MintingPolicy -> mp') red tks) -> - let change = extraTokens mp' - in ( Mint mp red (tks ++ change) : newMs, - Api.Value (PMap.singleton (Script.toCurrencySymbol mp') (PMap.unsafeFromList change)) <> addVal - ) - ) - ([], mempty) - oldMintsList + currencies <- viewTweak (txSkelMintsL % txSkelMintsAssetClassesG % to (fmap fst)) + oldMintsValue <- viewTweak (txSkelMintsL % to Script.toValue) + forM_ [(mp, tk, n) | mp <- currencies, (tk, n) <- extraTokens mp] $ \(mp, tk, n) -> + overTweak (txSkelMintsL % txSkelMintsAssetClassAmountL mp tk % _2) (+ n) + totalIncrement <- viewTweak (txSkelMintsL % to Script.toValue % to (<> PlutusTx.negate oldMintsValue)) guard (totalIncrement /= mempty) - setTweak (txSkelMintsL % txSkelMintsListI) newMintsList addOutputTweak $ attacker `receives` Value totalIncrement addLabelTweak AddTokenLbl return totalIncrement +-- | This attack is similar to 'addTokenAttack' with the exception that it only +-- tampers with token names already present. +-- +-- This attack adds an 'DupTokenLbl' label +dupTokenAttack :: + (MonadTweak m, IsTxSkelOutAllowedOwner o) => + -- | A function describing how the amount of tokens specified by a 'Mint' + -- constraint should be changed, depending on the asset class and the amount + -- specified by the constraint. The given function @f@ should probably satisfy + -- @f ac i > i@ for all @ac@ and @i@, i.e. it should increase the minted + -- amount. If it does not, the tweak will still succeed but this might result + -- in negative portions in the value paid to the attacker. + (VScript -> Api.TokenName -> Integer -> Integer) -> + -- | The target of the extra tokens. Any additional tokens that are minted by + -- the modified transaction but were not minted by the original transaction + -- are paid to this wallet. + o -> + m Api.Value +dupTokenAttack change attacker = do + mints <- viewTweak txSkelMintsL + res <- + addTokenAttack + ( \s -> + maybe + [] + (\(_, subMap) -> [(tk, change s tk n - n) | (tk, NonZero n) <- NEList.toList $ NEMap.toList subMap]) + (s `Map.lookup` mints) + ) + attacker + removeLabelTweak AddTokenLbl + addLabelTweak DupTokenLbl + return res + -- | A label that is added to a 'TxSkel' that has successfully been modified by -- 'addTokenAttack' data AddTokenLbl = AddTokenLbl deriving (Show, Eq, Ord) instance PrettyCooked AddTokenLbl where prettyCooked = PP.viaShow + +-- | A label that is added to a 'TxSkel' that has successfully been modified by +-- the 'dupTokenAttack' +data DupTokenLbl = DupTokenLbl + deriving (Eq, Show, Ord) + +instance PrettyCooked DupTokenLbl where + prettyCooked _ = "DupToken" diff --git a/src/Cooked/Attack/DatumHijacking.hs b/src/Cooked/Attack/DatumHijacking.hs index 01f7ed26..d5f5545a 100644 --- a/src/Cooked/Attack/DatumHijacking.hs +++ b/src/Cooked/Attack/DatumHijacking.hs @@ -3,12 +3,16 @@ -- | This module provides an automated attack to try and redirect outputs to a -- certain target with a similar datum type. module Cooked.Attack.DatumHijacking - ( redirectOutputTweakAny, - datumHijackingAttackAny, + ( redirectOutputTweakAll, + DatumHijackingParams (..), + DatumHijackingLabel (..), + redirectOutputTweakAny, datumHijackingAttack, - redirectOutputTweakAll, - datumHijackingAttackAll, - DatumHijackingLbl (..), + ownedByDatumHijackingParams, + scriptsDatumHijackingParams, + defaultDatumHijackingParams, + datumOfDatumHijackingParams, + txSkelOutPredDatumHijackingParams, ) where @@ -16,50 +20,99 @@ import Control.Monad import Cooked.Pretty.Class import Cooked.Skeleton import Cooked.Tweak +import Data.Bifunctor +import Data.Kind (Type) import Data.Maybe +import Data.Typeable import Optics.Core -import PlutusLedgerApi.V3 qualified as Api -import Prettyprinter ((<+>)) --- | Redirects some outputs from one owner to another owner, which can be of --- different types. +-- | The 'DatumHijackingLabel' stores the outputs that have been redirected, +-- before their destination were changed. +newtype DatumHijackingLabel = DatumHijackingLabel [TxSkelOut] + deriving (Show, Eq, Ord) + +instance PrettyCooked DatumHijackingLabel where + prettyCookedOpt opts (DatumHijackingLabel txSkelOuts) = prettyItemize opts "Redirected outputs" "-" txSkelOuts + +-- | Parameters of the datum hijacking attacks. They state precisely which +-- outputs should have their owner changed, wich owner should be assigned, to +-- each of these outputs, and whether several modified outputs should be +-- combined in a single transaction, or instead spread out multiple branches. +data DatumHijackingParams where + DatumHijackingParams :: + (IsTxSkelOutAllowedOwner owner) => + { -- | Return 'Just' the new owner, or 'Nothing' if you want to leave this + -- output unchanged. + dhpOutputPred :: TxSkelOut -> Maybe owner, + -- | The redirection described by the previous argument might apply to more + -- than one of the outputs of the transaction. Use this predicate to select + -- which of the redirectable outputs to actually redirect. We count the + -- redirectable outputs from the left to the right, starting with zero. + dhpIndexPred :: Integer -> Bool, + -- | Whether all the outputs targetted by the predicates should be + -- redirected in the same transaction, or one at a time, each in a + -- distinct transaction. + dhpAllOutputs :: Bool + } -> + DatumHijackingParams + +-- | Targets all the outputs for which the focus of a given optic exists, and +-- redirects each of them in a separate transaction. +defaultDatumHijackingParams :: (IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) => Optic' k is TxSkelOut x -> owner -> DatumHijackingParams +defaultDatumHijackingParams optic thief = + DatumHijackingParams + ((thief <$) . preview optic) + (const True) + False + +-- | Targets all the outputs satisfying a given predicate, and redirects each of +-- them in a separate transaction. +txSkelOutPredDatumHijackingParams :: (IsTxSkelOutAllowedOwner owner) => (TxSkelOut -> Bool) -> owner -> DatumHijackingParams +txSkelOutPredDatumHijackingParams predicate = defaultDatumHijackingParams (selectP predicate) + +-- | Datum hijacking parameters targetting all the outputs owned by a certain +-- type of owner, and redirecting each of them in a separate transaction. +ownedByDatumHijackingParams :: forall (oldOwner :: Type) owner. (IsTxSkelOutAllowedOwner owner, Typeable oldOwner) => owner -> DatumHijackingParams +ownedByDatumHijackingParams = defaultDatumHijackingParams (txSkelOutOwnerL % userTypedAF @oldOwner) + +-- | Datum hijacking parameters targetting all the outputs owned by a script, +-- and redirecting each of them in a separate transaction. +scriptsDatumHijackingParams :: (IsTxSkelOutAllowedOwner owner) => owner -> DatumHijackingParams +scriptsDatumHijackingParams = defaultDatumHijackingParams (txSkelOutOwnerL % userScriptHashAF) + +-- | Datum hijacking parameters targetting all the outputs with a certain type +-- of datum, and redirecting each of them in a separate transaction. +datumOfDatumHijackingParams :: forall dat owner. (IsTxSkelOutAllowedOwner owner, DatumConstrs dat) => owner -> DatumHijackingParams +datumOfDatumHijackingParams = defaultDatumHijackingParams (txSkelOutDatumL % txSkelOutDatumTypedAT @dat) + +-- | Redirects, in the same transaction, all the outputs targetted by an output +-- and an index predicates. See 'DatumHijackingParams' for more information on +-- those predicates. Returns a pair of the old outputs before they were +-- redirected, and the new updated list of outputs. redirectOutputTweakAll :: - forall owner owner' m. - (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => - -- | Return 'Just' the new owner, or 'Nothing' if you want to leave this - -- output unchanged. - (TxSkelOut -> Maybe owner') -> - -- | The redirection described by the previous argument might apply to more - -- than one of the outputs of the transaction. Use this predicate to select - -- which of the redirectable outputs to actually redirect. We count the - -- redirectable outputs from the left to the right, starting with zero. + (MonadTweak m, IsTxSkelOutAllowedOwner owner) => + (TxSkelOut -> Maybe owner) -> (Integer -> Bool) -> - -- | Returns the list of outputs it redirected (as they were - -- before the modification), in the order in which they occurred on the original - -- transaction. - m [TxSkelOut] + m ([TxSkelOut], [TxSkelOut]) redirectOutputTweakAll outputPred indexPred = do outputs <- viewTweak txSkelOutsL - let (changed, newOutputs) = unzip $ go outputs 0 - setTweak txSkelOutsL newOutputs - return $ catMaybes changed + return $ go outputs 0 where - go [] _ = [] + go [] _ = ([], []) go (out : l) n = - case preview (txSkelOutTypedOwnerAT @owner) out >> outputPred out of - Nothing -> (Nothing, out) : go l n - Just newOwner | indexPred n -> (Just out, out & txSkelOutTypedOwnerAT @owner .~ newOwner) : go l (n + 1) - _ -> (Nothing, out) : go l (n + 1) + case outputPred out of + Nothing -> second (out :) $ go l n + Just newOwner | indexPred n -> bimap (out :) ((out & txSkelOutOwnerL .~ toPKHOrVScript newOwner) :) $ go l (n + 1) + _ -> second (out :) $ go l (n + 1) --- | A version of 'redirectOutputTweakAll' where, instead of modifying all the --- outputs targeted by the input predicates in the same transaction, we modify --- one of them at a time, relying on the 'MonadPlus' instance of @m@. +-- | Redirects, each in their own transaction, all the outputs targetted by an +-- output and an index predicates. See 'DatumHijackingParams' for more +-- information on those predicates. redirectOutputTweakAny :: - forall owner owner' m. - (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => - (TxSkelOut -> Maybe owner') -> + (MonadTweak m, IsTxSkelOutAllowedOwner owner) => + (TxSkelOut -> Maybe owner) -> (Integer -> Bool) -> - m TxSkelOut + m ([TxSkelOut], [TxSkelOut]) redirectOutputTweakAny outputPred indexPred = viewTweak txSkelOutsL >>= go [] 0 where go _ _ [] = mzero @@ -68,81 +121,25 @@ redirectOutputTweakAny outputPred indexPred = viewTweak txSkelOutsL >>= go [] 0 fromMaybe (go (l' ++ [out]) (n + 1) l) ( do - void $ preview (txSkelOutTypedOwnerAT @owner) out newOwner <- outputPred out return $ mplus - (setTweak txSkelOutsL (l' ++ (out & txSkelOutTypedOwnerAT @owner .~ newOwner) : l) >> return out) + (return ([out], l' ++ (out & txSkelOutOwnerL .~ toPKHOrVScript newOwner) : l)) (go (l' ++ [out]) (n + 1) l) ) go l' n (out : l) = go (l' ++ [out]) n l -- | A datum hijacking attack, simplified: This attack tries to substitute a --- different recipient on outputs belonging to scripts, but leaves the datum as --- it is. That is, it tests for careless uses of something like --- 'Api.txInfoOutputs' in places where something like 'Api.getContinuingOutputs' --- should be used. If this attack goes through, however, a "proper" datum --- hijacking attack that modifies the datum in a way that (the relevant part of) --- the 'Api.toBuiltinData'-translation stays the same will also work. +-- different recipient on certain outputs based on a 'DatumHijackingParams'. -- --- A 'DatumHijackingLbl' with the hash of the "thief" validator is added to the --- labels of the 'TxSkel' using 'addLabelTweak'. --- --- This attack returns the list of outputs it redirected, in the order in which --- they occurred on the original transaction. If no output is redirected, this --- attack fails. -datumHijackingAttackAll :: - forall owner owner' m. - (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => - -- | Predicate to select outputs to steal, depending on the intended - -- recipient, the datum, and the value. - (TxSkelOut -> Bool) -> - -- | The selection predicate may match more than one output. Use this - -- predicate to restrict to the i-th of the outputs (counting from the left, - -- starting at zero) chosen by the selection predicate with this predicate. - (Integer -> Bool) -> - -- | The thief - owner' -> - m [TxSkelOut] -datumHijackingAttackAll change select thief = do - redirected <- redirectOutputTweakAll @owner (\output -> if change output then Just thief else Nothing) select - guard . not $ null redirected - addLabelTweak $ DatumHijackingLbl $ view ownerCredentialG thief - return redirected - --- | A version of datumHijackingAttackAll relying on the rules of --- 'redirectOutputTweakAny'. -datumHijackingAttackAny :: - forall owner owner' m. - (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => - -- | Predicate to select outputs to steal, depending on the intended - -- recipient, the datum, and the value. - (TxSkelOut -> Bool) -> - -- | The selection predicate may match more than one output. Use this - -- predicate to restrict to the i-th of the outputs (counting from the left, - -- starting at zero) chosen by the selection predicate with this predicate. - (Integer -> Bool) -> - -- | The thief - owner' -> - m TxSkelOut -datumHijackingAttackAny change select thief = do - redirected <- redirectOutputTweakAny @owner (\output -> if change output then Just thief else Nothing) select - addLabelTweak $ DatumHijackingLbl $ view ownerCredentialG thief +-- A 'DatumHijackingLabel' is added to the labels of the 'TxSkel' using +-- 'addLabelTweak'. It contains the outputs that have been redirected, which +-- also corresponds to the returned value of this tweak. The tweak fails if no +-- such outputs have been redirected. +datumHijackingAttack :: (MonadTweak m) => DatumHijackingParams -> m [TxSkelOut] +datumHijackingAttack (DatumHijackingParams outputPred indexPred mode) = do + (redirected, newOutputs) <- (if mode then redirectOutputTweakAll else redirectOutputTweakAny) outputPred indexPred + guard $ not $ null redirected + setTweak txSkelOutsL newOutputs + addLabelTweak $ DatumHijackingLabel redirected return redirected - --- | The default datum hijacking attack. It tries to redirect any output for --- which the owner is of type @owner@ and branches at each attempt. -datumHijackingAttack :: - forall owner owner' m. - (MonadTweak m, OwnerConstrs owner, OwnerConstrs owner') => - owner' -> - m TxSkelOut -datumHijackingAttack = datumHijackingAttackAny @owner (const True) (const True) - --- | A label that is added to a 'TxSkel' that has successfully been modified by --- any of the datum hijacking attacks -newtype DatumHijackingLbl = DatumHijackingLbl Api.Credential - deriving (Show, Eq, Ord) - -instance PrettyCooked DatumHijackingLbl where - prettyCookedOpt opts (DatumHijackingLbl address) = "DatumHijacking" <+> prettyCookedOpt opts address diff --git a/src/Cooked/Attack/DoubleSat.hs b/src/Cooked/Attack/DoubleSat.hs index d3c17d5f..c291cf91 100644 --- a/src/Cooked/Attack/DoubleSat.hs +++ b/src/Cooked/Attack/DoubleSat.hs @@ -17,6 +17,7 @@ import Cooked.Wallet import Data.Map (Map) import Data.Map qualified as Map import Optics.Core +import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api import PlutusTx.Numeric qualified as PlutusTx @@ -118,10 +119,7 @@ doubleSatAttack groupings optic change attacker = do deltaBalance :: (MonadTweak m) => DoubleSatDelta -> m Api.Value deltaBalance (inputs, outputs, mints) = do inValue <- foldMap (view txSkelOutValueL . snd) . filter ((`elem` Map.keys inputs) . fst) <$> allUtxos - return $ inValue <> PlutusTx.negate outValue <> mintValue - where - outValue = foldOf (traversed % txSkelOutValueL) outputs - mintValue = view txSkelMintsValueG mints + return $ inValue <> PlutusTx.negate (foldOf (traversed % txSkelOutValueL) outputs) <> Script.toValue mints -- Helper tweak to add a 'DoubleSatDelta' to a transaction addDoubleSatDeltaTweak :: (MonadTweak m) => DoubleSatDelta -> m () diff --git a/src/Cooked/Attack/DupToken.hs b/src/Cooked/Attack/DupToken.hs deleted file mode 100644 index decb5be7..00000000 --- a/src/Cooked/Attack/DupToken.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | This module provides an automated attack to duplicate tokens minted in a --- transaction. -module Cooked.Attack.DupToken (dupTokenAttack, DupTokenLbl (..)) where - -import Control.Monad -import Cooked.Pretty -import Cooked.Skeleton -import Cooked.Tweak -import Optics.Core -import Plutus.Script.Utils.Scripts qualified as Script -import PlutusLedgerApi.V1.Value qualified as Api - --- | A token duplication attack increases values in 'Mint' constraints of a --- 'TxSkel' according to some conditions, and pays the extra minted value to a --- given recipient wallet. This adds a 'DupTokenLbl' to the labels of the --- transaction using 'addLabelTweak'. Returns the 'Value' by which the minted --- value was increased. -dupTokenAttack :: - (MonadTweak m, OwnerConstrs o) => - -- | A function describing how the amount of tokens specified by a 'Mint' - -- constraint should be changed, depending on the asset class and the amount - -- specified by the constraint. The given function @f@ should probably satisfy - -- @f ac i > i@ for all @ac@ and @i@, i.e. it should increase the minted - -- amount. If it does *not* increase the minted amount, the amount will be - -- left unchanged. - (Api.AssetClass -> Integer -> Integer) -> - -- | The wallet of the attacker. Any additional tokens that are minted by the - -- modified transaction but were not minted by the original transaction are - -- paid to this wallet. - o -> - m Api.Value -dupTokenAttack change attacker = do - oldMintsList <- viewTweak $ txSkelMintsL % txSkelMintsListI - let (newMintsList, totalIncrement) = - foldl - ( \(newMs, addVal) (Mint mp@(Script.toCurrencySymbol . Script.toVersioned @Script.MintingPolicy -> cs) red tks) -> - let (newTokensList, addValTokens) = - foldl - ( \(newTks, addVal') (tn, n) -> - let newAmount = change (Api.assetClass cs tn) n - in if newAmount > n - then ((tn, newAmount) : newTks, addVal' <> Api.singleton cs tn (newAmount - n)) - else ((tn, n) : newTks, addVal') - ) - ([], mempty) - tks - in (Mint mp red newTokensList : newMs, addValTokens <> addVal) - ) - ([], mempty) - oldMintsList - guard (totalIncrement /= mempty) - setTweak (txSkelMintsL % txSkelMintsListI) newMintsList - addOutputTweak $ attacker `receives` Value totalIncrement - addLabelTweak DupTokenLbl - return totalIncrement - --- | A label that is added to a 'TxSkel' that has successfully been modified by --- the 'dupTokenAttack' -data DupTokenLbl = DupTokenLbl - deriving (Eq, Show, Ord) - -instance PrettyCooked DupTokenLbl where - prettyCooked _ = "DupToken" diff --git a/src/Cooked/MockChain/AutoReferenceScripts.hs b/src/Cooked/MockChain/AutoReferenceScripts.hs index ac5df524..6859ae84 100644 --- a/src/Cooked/MockChain/AutoReferenceScripts.hs +++ b/src/Cooked/MockChain/AutoReferenceScripts.hs @@ -16,16 +16,16 @@ import PlutusLedgerApi.V3 qualified as Api -- | Attempts to find in the index a utxo containing a reference script with the -- given script hash, and attaches it to a redeemer when it does not yet have a -- reference input and when it is allowed, in which case an event is logged. -updateRedeemer :: (MonadBlockChain m, Script.ToScriptHash s) => s -> [Api.TxOutRef] -> TxSkelRedeemer -> m TxSkelRedeemer -updateRedeemer script inputs txSkelRed@(TxSkelRedeemer _ Nothing True) = do - oRefsInInputs <- runUtxoSearch (referenceScriptOutputsSearch script) +updateRedeemedScript :: (MonadBlockChain m) => [Api.TxOutRef] -> User IsScript Redemption -> m (User IsScript Redemption) +updateRedeemedScript inputs rs@(UserRedeemedScript (toVScript -> vScript) txSkelRed@(TxSkelRedeemer {txSkelRedeemerAutoFill = True})) = do + oRefsInInputs <- runUtxoSearch (referenceScriptOutputsSearch vScript) maybe -- We leave the redeemer unchanged if no reference input was found - (return txSkelRed) + (return rs) -- If a reference input is found, we assign it and log the event ( \oRef -> do - logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash script) - return $ txSkelRed `withReferenceInput` oRef + logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash vScript) + return $ over userTxSkelRedeemerAT (autoFillReferenceInput oRef) rs ) $ case oRefsInInputs of [] -> Nothing @@ -33,28 +33,28 @@ updateRedeemer script inputs txSkelRed@(TxSkelRedeemer _ Nothing True) = do l | Just (oRefM', _) <- find (\(r, _) -> r `elem` inputs) l -> Just oRefM' -- If none exist, we use the first one we find elsewhere ((oRefM', _) : _) -> Just oRefM' -updateRedeemer _ _ redeemer = return redeemer +updateRedeemedScript _ rs = return rs -- | Goes through the various parts of the skeleton where a redeemer can appear, -- and attempts to attach a reference input to each of them, whenever it is -- allowed and one has not already been set. -toTxSkelWithReferenceScripts :: (MonadBlockChain m) => TxSkel -> m TxSkel -toTxSkelWithReferenceScripts txSkel@TxSkel {..} = do - let inputs = Map.keys txSkelIns - newMints <- forM (view txSkelMintsListI txSkelMints) $ \(Mint mPol red tks) -> - (\x -> Mint mPol x tks) <$> updateRedeemer (Script.toVersioned @Script.MintingPolicy mPol) inputs red - newInputs <- forM (Map.toList txSkelIns) $ \(oRef, red) -> do - validatorM <- previewByRef txSkelOutValidatorAT oRef - case validatorM of - Nothing -> return (oRef, red) - Just scriptHash -> (oRef,) <$> updateRedeemer scriptHash inputs red - newProposals <- forM txSkelProposals $ \prop -> - case prop ^. txSkelProposalWitnessL of +toTxSkelWithReferenceScripts :: forall m. (MonadBlockChain m) => TxSkel -> m TxSkel +toTxSkelWithReferenceScripts txSkel = do + let inputs = view (txSkelInsL % to Map.keys) txSkel + newMints <- forM (view (txSkelMintsL % txSkelMintsListI) txSkel) $ \(Mint rs tks) -> + (`Mint` tks) <$> updateRedeemedScript inputs rs + newInputs <- forM (view (txSkelInsL % to Map.toList) txSkel) $ \(oRef, red) -> + (oRef,) <$> do + validatorM <- previewByRef (txSkelOutOwnerL % userVScriptAT) oRef + case validatorM of + Nothing -> return red + Just val -> view userTxSkelRedeemerL <$> updateRedeemedScript inputs (UserRedeemedScript val red) + newProposals <- forM (view txSkelProposalsL txSkel) $ \prop -> + case preview (txSkelProposalMConstitutionAT % _Just) prop of Nothing -> return prop - Just (script, red) -> flip (set txSkelProposalWitnessL) prop . Just . (script,) <$> updateRedeemer script inputs red - newWithdrawals <- forM (Map.toList txSkelWithdrawals) $ \(wit, (red, quantity)) -> case wit of - Right _ -> return (wit, (red, quantity)) - Left script -> (Left script,) . (,quantity) <$> updateRedeemer script inputs red + Just rs -> flip (set (txSkelProposalMConstitutionAT % _Just)) prop <$> updateRedeemedScript inputs rs + newWithdrawals <- forM (view (txSkelWithdrawalsL % txSkelWithdrawalsByScriptsL % to Map.toList) txSkel) $ + \(vScript, (red, lv)) -> (vScript,) . (,lv) . view userTxSkelRedeemerL <$> updateRedeemedScript inputs (UserRedeemedScript vScript red) return $ txSkel & txSkelMintsL @@ -64,5 +64,5 @@ toTxSkelWithReferenceScripts txSkel@TxSkel {..} = do .~ Map.fromList newInputs & txSkelProposalsL .~ newProposals - & txSkelWithdrawalsL + & (txSkelWithdrawalsL % txSkelWithdrawalsByScriptsL) .~ Map.fromList newWithdrawals diff --git a/src/Cooked/MockChain/Balancing.hs b/src/Cooked/MockChain/Balancing.hs index 4aa30758..81d26afd 100644 --- a/src/Cooked/MockChain/Balancing.hs +++ b/src/Cooked/MockChain/Balancing.hs @@ -8,10 +8,11 @@ module Cooked.MockChain.Balancing ) where -import Cardano.Api.Ledger qualified as Cardano -import Cardano.Api.Shelley qualified as Cardano +import Cardano.Api qualified as Cardano +import Cardano.Ledger.BaseTypes qualified as Cardano import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway +import Cardano.Ledger.Plutus.ExUnits qualified as Cardano import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad import Control.Monad.Except @@ -101,7 +102,7 @@ balanceTxSkel skelUnbal@TxSkel {..} = do runUtxoSearch (txSkelOutByRefSearch (Set.toList utxos)) -- We filter out those belonging to scripts, while throwing a -- warning if any was actually discarded. - >>= filterAndWarn (is txSkelOutPKHashAT . snd) "They belong to scripts." + >>= filterAndWarn (is (txSkelOutOwnerL % userPubKeyHashAT) . snd) "They belong to scripts." -- We filter the candidate utxos by removing those already present in the -- skeleton, throwing a warning if any was actually discarded >>= filterAndWarn ((`notElem` txSkelKnownTxOutRefs skelUnbal) . fst) "They are already used in the skeleton." @@ -312,18 +313,26 @@ computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Wallet -> [(Api.TxOutRe computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (Script.lovelace -> feeValue) = do -- We compute the necessary values from the skeleton that are part of the -- equation, except for the `feeValue` which we already have. - let (burnedValue, mintedValue) = Api.split $ view txSkelMintsValueG txSkelMints + let (burnedValue, mintedValue) = Api.split $ Script.toValue txSkelMints outValue = txSkelValueInOutputs txSkel withdrawnValue = txSkelWithdrawnValue txSkel inValue <- txSkelInputValue txSkel - depositedValue <- Script.toValue <$> txSkelProposalsDeposit txSkel + certificatesDepositedValue <- Script.toValue <$> txSkelDepositedValueInCertificates txSkel + proposalsDepositedValue <- Script.toValue <$> txSkelDepositedValueInProposals txSkel -- We compute the values missing in the left and right side of the equation - let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> depositedValue <> PlutusTx.negate (inValue <> mintedValue <> withdrawnValue) + let (missingRight, missingLeft) = + Api.split $ + outValue + <> burnedValue + <> feeValue + <> proposalsDepositedValue + <> certificatesDepositedValue + <> PlutusTx.negate (inValue <> mintedValue <> withdrawnValue) -- We compute the minimal ada requirement of the missing payment rightMinAda <- getTxSkelOutMinAda $ balancingWallet `receives` Value missingRight -- We compute the current ada of the missing payment. If the missing payment -- is not empty and the minimal ada is not present, some value is missing. - let Api.Lovelace rightAda = missingRight ^. Script.adaL + let Api.Lovelace rightAda = missingRight ^. valueLovelaceL missingAda = rightMinAda - rightAda missingAdaValue = if missingRight /= mempty && missingAda > 0 then Script.lovelace missingAda else mempty -- The actual missing value on the left might needs to account for any missing diff --git a/src/Cooked/MockChain/BlockChain.hs b/src/Cooked/MockChain/BlockChain.hs index 8cb58a3f..21c9e0b0 100644 --- a/src/Cooked/MockChain/BlockChain.hs +++ b/src/Cooked/MockChain/BlockChain.hs @@ -31,22 +31,26 @@ module Cooked.MockChain.BlockChain slotRangeBefore, slotRangeAfter, slotToMSRange, - txSkelInputValidators, + txSkelInputScripts, txSkelInputValue, lookupUtxos, validateTxSkel', validateTxSkel_, - txSkelProposalsDeposit, + txSkelDepositedValueInProposals, govActionDeposit, defineM, txSkelAllScripts, previewByRef, viewByRef, + dRepDeposit, + stakeAddressDeposit, + stakePoolDeposit, + txSkelDepositedValueInCertificates, ) where import Cardano.Api.Ledger qualified as Cardano -import Cardano.Ledger.Conway.PParams qualified as Conway +import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Node.Emulator qualified as Emulator import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Lens qualified as Lens @@ -167,10 +171,10 @@ class (MonadBlockChainBalancing m) => MonadBlockChainWithoutValidation m where define :: (ToHash a) => String -> a -> m a -- | Sets the current script to act as the official constitution script - setConstitutionScript :: (Script.ToVersioned Script.Script s) => s -> m () + setConstitutionScript :: (ToVScript s) => s -> m () -- | Gets the current official constitution script - getConstitutionScript :: m (Maybe (Script.Versioned Script.Script)) + getConstitutionScript :: m (Maybe VScript) -- | Registers a staking credential with a given reward and deposit registerStakingCred :: (Script.ToCredential c) => c -> Integer -> Integer -> m () @@ -212,35 +216,76 @@ validateTxSkel_ = void . validateTxSkel -- afterwards using 'allUtxos' or similar functions. utxosFromCardanoTx :: (MonadBlockChainBalancing m) => Ledger.CardanoTx -> m [(Api.TxOutRef, TxSkelOut)] utxosFromCardanoTx = - mapM - ( \(_, txIn) -> - let txOutRef = Ledger.fromCardanoTxIn txIn - in (txOutRef,) <$> txSkelOutByRef txOutRef - ) + mapM (\txOutRef -> (txOutRef,) <$> txSkelOutByRef txOutRef) + . fmap (Ledger.fromCardanoTxIn . snd) . Ledger.getCardanoTxOutRefs -- | Like 'define', but binds the result of a monadic computation instead defineM :: (MonadBlockChainWithoutValidation m, ToHash a) => String -> m a -> m a defineM name = (define name =<<) --- | Retrieves the required deposit amount for issuing governance actions. +-- | Retrieves the required governance action deposit amount govActionDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace govActionDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppGovActionDepositL . Emulator.emulatorPParams <$> getParams +-- | Retrieves the required drep deposit amount +dRepDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace +dRepDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppDRepDepositL . Emulator.emulatorPParams <$> getParams + +-- | Retrieves the required stake address deposit amount +stakeAddressDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace +stakeAddressDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppKeyDepositL . Emulator.emulatorPParams <$> getParams + +-- | Retrieves the required stake pool deposit amount +stakePoolDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace +stakePoolDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppPoolDepositL . Emulator.emulatorPParams <$> getParams + -- | Retrieves the total amount of lovelace deposited in proposals in this -- skeleton (equal to `govActionDeposit` times the number of proposals). -txSkelProposalsDeposit :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace -txSkelProposalsDeposit TxSkel {..} = Api.Lovelace . (toInteger (length txSkelProposals) *) . Api.getLovelace <$> govActionDeposit - --- | Returns all validators which guard transaction inputs -txSkelInputValidators :: (MonadBlockChainBalancing m) => TxSkel -> m [Script.Versioned Script.Validator] -txSkelInputValidators = fmap (mapMaybe (preview txSkelOutValidatorAT)) . mapM txSkelOutByRef . Map.keys . txSkelIns +txSkelDepositedValueInProposals :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace +txSkelDepositedValueInProposals TxSkel {txSkelProposals} = Api.Lovelace . (toInteger (length txSkelProposals) *) . Api.getLovelace <$> govActionDeposit + +-- | Retrieves the total amount of lovelace deposited in certificates in this +-- skeleton. Note that unregistering a staking address or a dRep lead to a +-- negative deposit (a withdrawal, in fact) which means this function can return +-- a negative amount of lovelace, which is intended. The deposited amounts are +-- dictated by the current protocol parameters, and computed as such. +txSkelDepositedValueInCertificates :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace +txSkelDepositedValueInCertificates txSkel = do + sDep <- stakeAddressDeposit + dDep <- dRepDeposit + return $ + foldOf + ( txSkelCertificatesL + % traversed + % txSkelCertificateActionAT @IsEither + % to + ( \case + StakingRegister {} -> sDep + StakingRegisterDelegate {} -> sDep + StakingUnRegister {} -> -sDep + DRepRegister {} -> dDep + DRepUnRegister {} -> -dDep + _ -> Api.Lovelace 0 + ) + ) + txSkel + +-- | Returns all scripts which guard transaction inputs +txSkelInputScripts :: (MonadBlockChainBalancing m) => TxSkel -> m [VScript] +txSkelInputScripts = fmap catMaybes . mapM (previewByRef (txSkelOutOwnerL % userVScriptAT)) . Map.keys . txSkelIns -- | Returns all scripts involved in this 'TxSkel' -txSkelAllScripts :: (MonadBlockChainBalancing m) => TxSkel -> m [Script.Versioned Script.Script] +txSkelAllScripts :: (MonadBlockChainBalancing m) => TxSkel -> m [VScript] txSkelAllScripts txSkel = do - txSkelSpendingScripts <- fmap Script.toVersioned <$> txSkelInputValidators txSkel - return (txSkelMintingScripts txSkel <> txSkelWithdrawingScripts txSkel <> txSkelProposingScripts txSkel <> txSkelSpendingScripts) + txSkelSpendingScripts <- txSkelInputScripts txSkel + return + ( txSkelMintingScripts txSkel + <> txSkelWithdrawingScripts txSkel + <> txSkelProposingScripts txSkel + <> txSkelCertifyingScripts txSkel + <> txSkelSpendingScripts + ) -- | Go through all of the 'Api.TxOutRef's in the list and look them up in the -- state of the blockchain, throwing an error if one of them cannot be resolved. diff --git a/src/Cooked/MockChain/Direct.hs b/src/Cooked/MockChain/Direct.hs index a699b502..b160555a 100644 --- a/src/Cooked/MockChain/Direct.hs +++ b/src/Cooked/MockChain/Direct.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE DeriveFunctor #-} + -- | This module provides a direct (as opposed to 'Cooked.MockChain.Staged') -- implementation of the `MonadBlockChain` specification. This rely on the -- emulator from cardano-node-emulator for transaction validation, although we -- have our own internal state. This choice might be revised in the future. module Cooked.MockChain.Direct where +import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano -import Cardano.Api.Shelley qualified as Cardano import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Applicative import Control.Lens qualified as Lens @@ -20,8 +22,8 @@ import Cooked.MockChain.AutoReferenceScripts import Cooked.MockChain.Balancing import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx -import Cooked.MockChain.GenerateTx.Common import Cooked.MockChain.GenerateTx.Output +import Cooked.MockChain.GenerateTx.Witness import Cooked.MockChain.MinAda import Cooked.MockChain.MockChainState import Cooked.MockChain.UtxoState (UtxoState) @@ -62,12 +64,14 @@ import PlutusLedgerApi.V3 qualified as Api -- worth logging, or aliases for hashables corresponding to elements users -- wishes to be properly displayed when printed with -- 'Cooked.Pretty.Class.PrettyCooked' -data MockChainBook = MockChainBook - { -- | Log entries generated by cooked-validators - mcbJournal :: [MockChainLogEntry], - -- | Aliases stored by the user - mcbAliases :: Map Api.BuiltinByteString String - } +data MockChainBook where + MockChainBook :: + { -- | Log entries generated by cooked-validators + mcbJournal :: [MockChainLogEntry], + -- | Aliases stored by the user + mcbAliases :: Map Api.BuiltinByteString String + } -> + MockChainBook instance Semigroup MockChainBook where MockChainBook j a <> MockChainBook j' a' = MockChainBook (j <> j') (a <> a') @@ -108,11 +112,7 @@ instance (Monad m, Alternative m) => Alternative (MockChainT m) where (<|>) = combineMockChainT (<|>) -- | Combines two 'MockChainT' together -combineMockChainT :: - (forall a. m a -> m a -> m a) -> - MockChainT m x -> - MockChainT m x -> - MockChainT m x +combineMockChainT :: (forall a. m a -> m a -> m a) -> MockChainT m x -> MockChainT m x -> MockChainT m x combineMockChainT f ma mb = MockChainT $ ExceptT $ StateT $ \s -> @@ -123,24 +123,24 @@ combineMockChainT f ma mb = MockChainT $ -- | The returned type when running a 'MockChainT'. This is both a reorganizing -- and filtering of the natural returned type @((Either MockChainError a, -- MockChainState), MockChainBook)@, which is much easier to query. -data MockChainReturn a = MockChainReturn - { -- | The returned value of the run - mcrValue :: Either MockChainError a, - -- | All the outputs used throughout the run - mcrOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), - -- | The resulting 'UtxoState' of the run - mcrUtxoState :: UtxoState, - -- | The log entries emitted during the run - mcrJournal :: [MockChainLogEntry], - -- | The aliases defined during the run - mcrAliases :: Map Api.BuiltinByteString String - } +data MockChainReturn a where + MockChainReturn :: + { -- | The value returned by the computation, or an error + mcrValue :: Either MockChainError a, + -- | The outputs at the end of the run + mcrOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), + -- | The 'UtxoState' at the end of the run + mcrUtxoState :: UtxoState, + -- | The final journal emitted during the run + mcrJournal :: [MockChainLogEntry], + -- | The map of aliases defined during the run + mcrAliases :: Map Api.BuiltinByteString String + } -> + MockChainReturn a + deriving (Functor) -- | Runs a 'MockChainT' from a default 'MockChainState' -runMockChainTRaw :: - (Monad m) => - MockChainT m a -> - m (MockChainReturn a) +runMockChainTRaw :: (Monad m) => MockChainT m a -> m (MockChainReturn a) runMockChainTRaw = fmap mkMockChainReturn . runWriterT . flip runStateT def . runExceptT . unMockChain where mkMockChainReturn ((val, st), MockChainBook journal aliases) = @@ -148,11 +148,7 @@ runMockChainTRaw = fmap mkMockChainReturn . runWriterT . flip runStateT def . ru -- | Runs a 'MockChainT' from an initial 'MockChainState' built from a given -- 'InitialDistribution'. -runMockChainTFrom :: - (Monad m) => - InitialDistribution -> - MockChainT m a -> - m (MockChainReturn a) +runMockChainTFrom :: (Monad m) => InitialDistribution -> MockChainT m a -> m (MockChainReturn a) runMockChainTFrom (InitialDistribution i0) = runMockChainTRaw . (forceOutputs i0 >>) -- | Executes a 'MockChainT' from the canonical initial state and environment. @@ -199,7 +195,7 @@ instance (Monad m) => MonadBlockChainWithoutValidation (MockChainT m) where return newSlot | otherwise -> throwError $ MCEPastSlot cs (cs + fromIntegral n) define name hashable = tell (MockChainBook [] (Map.singleton (toHash hashable) name)) >> return hashable - setConstitutionScript (Script.toVersioned -> cScript) = do + setConstitutionScript (toVScript -> cScript) = do modify' (mcstConstitutionL ?~ cScript) modify' $ over mcstLedgerStateL $ @@ -208,11 +204,7 @@ instance (Monad m) => MonadBlockChainWithoutValidation (MockChainT m) where cScript getConstitutionScript = gets (view mcstConstitutionL) registerStakingCred (Script.toCredential -> cred) reward deposit = do - stakeCredential <- - throwOnToCardanoErrorOrApply - "Unable to convert staking credential" - Cardano.toShelleyStakeCredential - (Ledger.toCardanoStakeCredential cred) + stakeCredential <- toStakeCredential cred modify' $ over mcstLedgerStateL @@ -236,10 +228,10 @@ instance (Monad m) => MonadBlockChain (MockChainT m) where -- We ensure that the outputs have the required minimal amount of ada, when -- requested in the skeleton options minAdaSkelUnbal <- toTxSkelWithMinAda skelUnbal - -- We retrieve the official constitution script - constitution <- getConstitutionScript - -- We attach the script to each proposal that requires it - let minAdaSkelUnbalWithConst = over (txSkelProposalsL % traversed) (`updateConstitution` constitution) minAdaSkelUnbal + -- We retrieve the official constitution script and attach it to each + -- proposal that requires it, if it's not empty + minAdaSkelUnbalWithConst <- + getConstitutionScript <&> maybe minAdaSkelUnbal (flip (over (txSkelProposalsL % traversed)) minAdaSkelUnbal . autoFillConstitution) -- We add reference scripts in the various redeemers of the skeleton, when -- they can be found in the index and are allowed to be auto filled minAdaRefScriptsSkelUnbalWithConst <- toTxSkelWithReferenceScripts minAdaSkelUnbalWithConst diff --git a/src/Cooked/MockChain/GenerateTx.hs b/src/Cooked/MockChain/GenerateTx.hs index ff3ad5ff..921fd83b 100644 --- a/src/Cooked/MockChain/GenerateTx.hs +++ b/src/Cooked/MockChain/GenerateTx.hs @@ -6,7 +6,7 @@ module Cooked.MockChain.GenerateTx ) where -import Cardano.Api.Shelley qualified as Cardano +import Cardano.Api qualified as Cardano import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx.Body import Cooked.MockChain.GenerateTx.Witness diff --git a/src/Cooked/MockChain/GenerateTx/Anchor.hs b/src/Cooked/MockChain/GenerateTx/Anchor.hs new file mode 100644 index 00000000..68f8521b --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Anchor.hs @@ -0,0 +1,32 @@ +-- | Transforming 'TxSkelAnchor' into its Cardano counterpart +module Cooked.MockChain.GenerateTx.Anchor (toCardanoAnchor) where + +import Cardano.Ledger.BaseTypes qualified as Cardano +import Cardano.Ledger.Conway.Core qualified as Conway +import Control.Monad.Catch +import Cooked.Skeleton.Anchor +import Data.Default +import Data.Functor +import Data.Maybe +import Data.Text qualified as Text +import GHC.IO.Unsafe +import Network.HTTP.Simple qualified as Network + +-- | This function transforms a 'TxSkelAnchor' into its Cardano counterpart. If +-- the provided anchor does not provde a resolved page, it will be unsafely +-- fetched online, so use at your own discretion. +toCardanoAnchor :: TxSkelAnchor -> Cardano.Anchor +toCardanoAnchor txSkelAnchor = + fromMaybe def $ + do + (url, page) <- txSkelAnchor + anchorUrl <- Cardano.textToUrl (length url) (Text.pack url) + fmap (Cardano.Anchor anchorUrl . Conway.hashAnnotated . Cardano.AnchorData) $ case page of + Just resolvedPage -> return resolvedPage + Nothing -> + -- WARNING: very unsafe and unreproducible + unsafePerformIO + ( handle + (return . fail . (("Error when parsing anchor " ++ show url ++ " with error: ") ++) . (show @Network.HttpException)) + ((Network.parseRequest url >>= Network.httpBS) <&> return . Network.getResponseBody) + ) diff --git a/src/Cooked/MockChain/GenerateTx/Body.hs b/src/Cooked/MockChain/GenerateTx/Body.hs index 62130473..7788c31d 100644 --- a/src/Cooked/MockChain/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/GenerateTx/Body.hs @@ -9,14 +9,11 @@ module Cooked.MockChain.GenerateTx.Body where import Cardano.Api qualified as Cardano -import Cardano.Api.Internal.Fees qualified as Cardano -import Cardano.Api.Internal.Script qualified as Cardano -import Cardano.Api.Internal.Tx.Body qualified as Cardano -import Cardano.Api.Ledger qualified as Cardano import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad import Control.Monad.Except import Cooked.MockChain.BlockChain +import Cooked.MockChain.GenerateTx.Certificate import Cooked.MockChain.GenerateTx.Collateral import Cooked.MockChain.GenerateTx.Common import Cooked.MockChain.GenerateTx.Input @@ -66,15 +63,13 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do (Cardano.TxExtraKeyWitnesses Cardano.AlonzoEraOnwardsConway) $ mapM (Ledger.toCardanoPaymentKeyHash . Ledger.PaymentPubKeyHash . Script.toPubKeyHash) txSkelSigners txProtocolParams <- Cardano.BuildTxWith . Just . Emulator.ledgerProtocolParameters <$> getParams - txProposalProcedures <- - Just . Cardano.Featured Cardano.ConwayEraOnwardsConway - <$> toProposalProcedures txSkelProposals (txSkelOptAnchorResolution txSkelOpts) + txProposalProcedures <- Just . Cardano.Featured Cardano.ConwayEraOnwardsConway <$> toProposalProcedures txSkelProposals txWithdrawals <- toWithdrawals txSkelWithdrawals + txCertificates <- toCertificates txSkelCertificates let txFee = Cardano.TxFeeExplicit Cardano.ShelleyBasedEraConway $ Cardano.Coin fee txMetadata = Cardano.TxMetadataNone txAuxScripts = Cardano.TxAuxScriptsNone txUpdateProposal = Cardano.TxUpdateProposalNone - txCertificates = Cardano.TxCertificatesNone txScriptValidity = Cardano.TxScriptValidityNone txVotingProcedures = Nothing txCurrentTreasuryValue = Nothing diff --git a/src/Cooked/MockChain/GenerateTx/Certificate.hs b/src/Cooked/MockChain/GenerateTx/Certificate.hs new file mode 100644 index 00000000..0e21272a --- /dev/null +++ b/src/Cooked/MockChain/GenerateTx/Certificate.hs @@ -0,0 +1,91 @@ +-- | This module provide primitives to transform certificates from our skeleton +-- to certificate in Cardano transaction bodies. +module Cooked.MockChain.GenerateTx.Certificate (toCertificates) where + +import Cardano.Api qualified as Cardano +import Cardano.Ledger.Conway.TxCert qualified as Conway +import Cardano.Ledger.DRep qualified as Ledger +import Cardano.Ledger.PoolParams qualified as Ledger +import Cardano.Ledger.Shelley.TxCert qualified as Shelley +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Cooked.MockChain.BlockChain +import Cooked.MockChain.GenerateTx.Witness +import Cooked.Skeleton.Certificate +import Cooked.Skeleton.User +import Data.Default +import Data.Maybe.Strict +import Optics.Core +import Plutus.Script.Utils.Address qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +toDRep :: (MonadBlockChainBalancing m) => Api.DRep -> m Ledger.DRep +toDRep Api.DRepAlwaysAbstain = return Ledger.DRepAlwaysAbstain +toDRep Api.DRepAlwaysNoConfidence = return Ledger.DRepAlwaysNoConfidence +toDRep (Api.DRep (Api.DRepCredential cred)) = Ledger.DRepCredential <$> toDRepCredential cred + +toDelegatee :: (MonadBlockChainBalancing m) => Api.Delegatee -> m Conway.Delegatee +toDelegatee (Api.DelegStake pkh) = Conway.DelegStake <$> toStakePoolKeyHash pkh +toDelegatee (Api.DelegVote dRep) = Conway.DelegVote <$> toDRep dRep +toDelegatee (Api.DelegStakeVote pkh dRep) = liftA2 Conway.DelegStakeVote (toStakePoolKeyHash pkh) (toDRep dRep) + +toCertificate :: (MonadBlockChainBalancing m) => TxSkelCertificate -> m (Cardano.Certificate Cardano.ConwayEra) +toCertificate txSkelCert = + do + depositStake <- Cardano.Coin . Api.getLovelace <$> stakeAddressDeposit + depositDRep <- Cardano.Coin . Api.getLovelace <$> dRepDeposit + Cardano.ConwayCertificate Cardano.ConwayEraOnwardsConway <$> case txSkelCert of + TxSkelCertificate (Script.toCredential -> cred) StakingRegister -> + Conway.ConwayTxCertDeleg . (`Conway.ConwayRegCert` SJust depositStake) <$> toStakeCredential cred + TxSkelCertificate (Script.toCredential -> cred) StakingUnRegister -> + Conway.ConwayTxCertDeleg . (`Conway.ConwayUnRegCert` SJust depositStake) <$> toStakeCredential cred + TxSkelCertificate (Script.toCredential -> cred) (StakingDelegate delegatee) -> + Conway.ConwayTxCertDeleg <$> liftA2 Conway.ConwayDelegCert (toStakeCredential cred) (toDelegatee delegatee) + TxSkelCertificate (Script.toCredential -> cred) (StakingRegisterDelegate delegatee) -> + Conway.ConwayTxCertDeleg . (depositStake &) <$> liftA2 Conway.ConwayRegDelegCert (toStakeCredential cred) (toDelegatee delegatee) + TxSkelCertificate (Script.toCredential -> cred) DRepRegister -> + Conway.ConwayTxCertGov . (\c -> Conway.ConwayRegDRep c depositDRep SNothing) <$> toDRepCredential cred + TxSkelCertificate (Script.toCredential -> cred) DRepUpdate -> + Conway.ConwayTxCertGov . (`Conway.ConwayUpdateDRep` SNothing) <$> toDRepCredential cred + TxSkelCertificate (Script.toCredential -> cred) DRepUnRegister -> + Conway.ConwayTxCertGov . (`Conway.ConwayUnRegDRep` depositDRep) <$> toDRepCredential cred + -- TODO: For now, when registering a new pool we use the default parameters + -- excepct for the pool id and pool vrf. We could change it later on. + TxSkelCertificate (UserPubKey (Script.toPubKeyHash -> poolHash)) (PoolRegister poolVrf) -> + Conway.ConwayTxCertPool . Shelley.RegPool + <$> liftA2 + (\pId pVrf -> def {Ledger.ppId = pId, Ledger.ppVrf = pVrf}) + (toStakePoolKeyHash poolHash) + (toVRFVerKeyHash poolVrf) + TxSkelCertificate (UserPubKey (Script.toPubKeyHash -> poolHash)) (PoolRetire slot) -> + Conway.ConwayTxCertPool + <$> liftA2 + Shelley.RetirePool + (toStakePoolKeyHash poolHash) + ( do + eeh <- Emulator.emulatorEraHistory <$> getParams + case Cardano.slotToEpoch (fromIntegral slot) eeh of + -- TODO: we could have a dedicated error for this case if the + -- can occur at several places in the codebase + Left _ -> fail "Too far away in the future" + Right (epoch, _, _) -> return epoch + ) + TxSkelCertificate (Script.toCredential -> coldCred) (CommitteeRegisterHot hotCred) -> + Conway.ConwayTxCertGov <$> liftA2 Conway.ConwayAuthCommitteeHotKey (toColdCredential coldCred) (toHotCredential hotCred) + TxSkelCertificate (Script.toCredential -> cred) CommitteeResign -> + Conway.ConwayTxCertGov . (`Conway.ConwayResignCommitteeColdKey` SNothing) <$> toColdCredential cred + +toCertificateWitness :: (MonadBlockChainBalancing m) => TxSkelCertificate -> m (Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra)) +toCertificateWitness = + maybe + (return Nothing) + ( \case + (UserRedeemedScript s red) -> Just <$> toScriptWitness s red Cardano.NoScriptDatumForStake + _ -> return Nothing + ) + . preview (txSkelCertificateOwnerAT @IsEither) + +-- | Builds a 'Cardano.TxCertificates' from a list of 'TxSkelCertificate' +toCertificates :: (MonadBlockChainBalancing m) => [TxSkelCertificate] -> m (Cardano.TxCertificates Cardano.BuildTx Cardano.ConwayEra) +toCertificates = + fmap (Cardano.mkTxCertificates Cardano.ShelleyBasedEraConway) + . mapM (\txSkelCert -> liftA2 (,) (toCertificate txSkelCert) (toCertificateWitness txSkelCert)) diff --git a/src/Cooked/MockChain/GenerateTx/Collateral.hs b/src/Cooked/MockChain/GenerateTx/Collateral.hs index 39a75e48..1b802fea 100644 --- a/src/Cooked/MockChain/GenerateTx/Collateral.hs +++ b/src/Cooked/MockChain/GenerateTx/Collateral.hs @@ -3,8 +3,6 @@ module Cooked.MockChain.GenerateTx.Collateral where import Cardano.Api qualified as Cardano -import Cardano.Api.Ledger qualified as Cardano -import Cardano.Api.Shelley qualified as Cardano hiding (Testnet) import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad diff --git a/src/Cooked/MockChain/GenerateTx/Input.hs b/src/Cooked/MockChain/GenerateTx/Input.hs index cfa67a5a..4bfce560 100644 --- a/src/Cooked/MockChain/GenerateTx/Input.hs +++ b/src/Cooked/MockChain/GenerateTx/Input.hs @@ -16,12 +16,12 @@ toTxInAndWitness :: (Api.TxOutRef, TxSkelRedeemer) -> m (Cardano.TxIn, Cardano.BuildTxWith Cardano.BuildTx (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra)) toTxInAndWitness (txOutRef, txSkelRedeemer) = do - TxSkelOut (toPKHOrValidator -> owner) _ datum _ _ _ <- txSkelOutByRef txOutRef + TxSkelOut owner _ datum _ _ _ <- txSkelOutByRef txOutRef witness <- case owner of - Left _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending - Right validator -> + UserPubKey _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending + UserScript script -> fmap (Cardano.ScriptWitness Cardano.ScriptWitnessForSpending) $ - toScriptWitness validator txSkelRedeemer $ + toScriptWitness script txSkelRedeemer $ case datum of NoTxSkelOutDatum -> Cardano.ScriptDatumForTxIn Nothing SomeTxSkelOutDatum _ Inline -> Cardano.InlineScriptDatum diff --git a/src/Cooked/MockChain/GenerateTx/Mint.hs b/src/Cooked/MockChain/GenerateTx/Mint.hs index 99a92226..cb40edf2 100644 --- a/src/Cooked/MockChain/GenerateTx/Mint.hs +++ b/src/Cooked/MockChain/GenerateTx/Mint.hs @@ -25,12 +25,12 @@ toMintValue mints = fmap (Cardano.TxMintValue Cardano.MaryEraOnwardsConway . SMa policyId <- throwOnToCardanoError "toMintValue: Unable to translate minting policy hash" - (Ledger.toCardanoPolicyId $ Script.toMintingPolicyHash policy) + (Ledger.toCardanoPolicyId $ Script.toMintingPolicyHash $ Script.toScriptHash policy) mintWitness <- Cardano.BuildTxWith <$> toScriptWitness policy red Cardano.NoScriptDatumForMint return ( policyId, ( fromList - [ (Cardano.AssetName name, Cardano.Quantity quantity) + [ (Cardano.UnsafeAssetName name, Cardano.Quantity quantity) | (Api.TokenName (PlutusTx.BuiltinByteString name), NonZero quantity) <- assets ], mintWitness diff --git a/src/Cooked/MockChain/GenerateTx/Output.hs b/src/Cooked/MockChain/GenerateTx/Output.hs index 43525631..5279676a 100644 --- a/src/Cooked/MockChain/GenerateTx/Output.hs +++ b/src/Cooked/MockChain/GenerateTx/Output.hs @@ -1,7 +1,7 @@ -- | This modules exposes the generation of transaction outputs module Cooked.MockChain.GenerateTx.Output (toCardanoTxOut) where -import Cardano.Api.Shelley qualified as Cardano +import Cardano.Api qualified as Cardano import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx.Common @@ -17,7 +17,7 @@ toCardanoTxOut output = do let oAddress = view txSkelOutAddressG output oValue = view txSkelOutValueL output oDatum = output ^. txSkelOutDatumL - oRefScript = preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptVersionedP) output + oRefScript = view txSkelOutMReferenceScriptL output networkId <- Emulator.pNetworkId <$> getParams address <- throwOnToCardanoError diff --git a/src/Cooked/MockChain/GenerateTx/Proposal.hs b/src/Cooked/MockChain/GenerateTx/Proposal.hs index 7e53deb4..e146f77f 100644 --- a/src/Cooked/MockChain/GenerateTx/Proposal.hs +++ b/src/Cooked/MockChain/GenerateTx/Proposal.hs @@ -8,32 +8,27 @@ import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Ledger.Conway.Governance qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Control.Lens qualified as Lens -import Control.Monad.Catch +import Control.Monad import Control.Monad.Except (throwError) import Cooked.MockChain.BlockChain +import Cooked.MockChain.GenerateTx.Anchor import Cooked.MockChain.GenerateTx.Common import Cooked.MockChain.GenerateTx.Witness import Cooked.Skeleton -import Data.Default +import Data.Coerce import Data.Map qualified as Map import Data.Map.Ordered.Strict qualified as OMap -import Data.Map.Strict qualified as SMap import Data.Maybe import Data.Maybe.Strict -import Data.Text qualified as Text -import GHC.IO.Unsafe import Ledger.Tx.CardanoAPI qualified as Ledger import Lens.Micro qualified as MicroLens -import Network.HTTP.Simple qualified as Network -import Optics.Core import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V1.Value qualified as Api --- | Transorms a `TxParameterChange` into an actual change over a Cardano --- parameter update -toPParamsUpdate :: TxParameterChange -> Conway.PParamsUpdate Emulator.EmulatorEra -> Conway.PParamsUpdate Emulator.EmulatorEra +-- | Transorms a `Cooked.Skeleton.Proposal.ParameterChange` into an actual +-- change over a Cardano parameter update +toPParamsUpdate :: ParameterChange -> Conway.PParamsUpdate Emulator.EmulatorEra -> Conway.PParamsUpdate Emulator.EmulatorEra toPParamsUpdate pChange = -- From rational to bounded rational let toBR :: (Cardano.BoundedRational r) => Rational -> r @@ -77,70 +72,35 @@ toPParamsUpdate pChange = MinFeeRefScriptCostPerByte q -> setL Conway.ppuMinFeeRefScriptCostPerByteL $ fromMaybe minBound $ Cardano.boundRational q -- | Translates a given skeleton proposal into a governance action -toGovAction :: (MonadBlockChainBalancing m) => TxSkelProposal -> m (Conway.GovAction Emulator.EmulatorEra) -toGovAction TxSkelProposal {..} = do - sHash <- case txSkelProposalWitness of - Nothing -> return SNothing - Just (script, _) -> do - Cardano.ScriptHash sHash <- - throwOnToCardanoError - "Unable to convert script hash" - (Ledger.toCardanoScriptHash (Script.toScriptHash script)) - return $ SJust sHash - case txSkelProposalAction of - TxGovActionParameterChange changes -> - return $ - Conway.ParameterChange - SNothing -- TODO, should not be Nothing later on - (foldl (flip toPParamsUpdate) (Conway.PParamsUpdate Cardano.emptyPParamsStrictMaybe) changes) - sHash - TxGovActionHardForkInitiation _ -> throwError $ MCEUnsupportedFeature "TxGovActionHardForkInitiation" - TxGovActionTreasuryWithdrawals mapCredentialLovelace -> do - cardanoMap <- SMap.fromList <$> mapM (\(cred, Api.Lovelace lv) -> (,Cardano.Coin lv) <$> toRewardAccount cred) (Map.toList mapCredentialLovelace) - return $ Conway.TreasuryWithdrawals cardanoMap sHash - TxGovActionNoConfidence -> return $ Conway.NoConfidence SNothing -- TODO, should not be Nothing later on - TxGovActionUpdateCommittee {} -> throwError $ MCEUnsupportedFeature "TxGovActionUpdateCommittee" - TxGovActionNewConstitution _ -> throwError $ MCEUnsupportedFeature "TxGovActionNewConstitution" - --- | Translates a skeleton proposal into a proposal procedure alongside a --- possible witness -toProposalProcedureAndWitness :: - (MonadBlockChainBalancing m) => - TxSkelProposal -> - AnchorResolution -> - m (Conway.ProposalProcedure Emulator.EmulatorEra, Cardano.BuildTxWith Cardano.BuildTx (Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra))) -toProposalProcedureAndWitness txSkelProposal@TxSkelProposal {..} anchorResolution = do - minDeposit <- Cardano.unCoin . Lens.view Conway.ppGovActionDepositL . Emulator.pEmulatorPParams <$> getParams - cred <- toRewardAccount $ Script.toCredential txSkelProposalAddress - govAction <- toGovAction txSkelProposal - let proposalAnchor = do - anchor <- txSkelProposalAnchor - anchorUrl <- Cardano.textToUrl (length anchor) (Text.pack anchor) - let anchorDataHash = - case anchorResolution of - AnchorResolutionHttp -> - -- WARNING: very unsafe and unreproducible - unsafePerformIO - ( handle - (return . fail . (("Error when parsing anchor " ++ show anchor ++ " with error: ") ++) . (show @Network.HttpException)) - ((Network.parseRequest anchor >>= Network.httpBS) <&> return . Network.getResponseBody) - ) - AnchorResolutionLocal urls -> case Map.lookup anchor urls of - Nothing -> fail "Error when attempting to retrieve anchor url in the local anchor resolution map" - Just x -> return x - return $ Cardano.Anchor anchorUrl . Conway.hashAnnotated . Cardano.AnchorData <$> anchorDataHash - anchor <- fromMaybe (return def) proposalAnchor - let conwayProposalProcedure = Conway.ProposalProcedure (Cardano.Coin minDeposit) cred govAction anchor - (conwayProposalProcedure,) . Cardano.BuildTxWith <$> case txSkelProposalWitness of - Nothing -> return Nothing - Just (script, redeemer) -> Just <$> toScriptWitness script redeemer Cardano.NoScriptDatumForStake +toGovAction :: (MonadBlockChainBalancing m) => GovernanceAction a -> StrictMaybe Conway.ScriptHash -> m (Conway.GovAction Emulator.EmulatorEra) +toGovAction NoConfidence _ = return $ Conway.NoConfidence SNothing +toGovAction UpdateCommittee {} _ = throwError $ MCEUnsupportedFeature "UpdateCommittee" +toGovAction NewConstitution {} _ = throwError $ MCEUnsupportedFeature "TxGovActionNewConstitution" +toGovAction HardForkInitiation {} _ = throwError $ MCEUnsupportedFeature "TxGovActionHardForkInitiation" +toGovAction (ParameterChange changes) sHash = + return $ Conway.ParameterChange SNothing (foldl (flip toPParamsUpdate) (Conway.PParamsUpdate Cardano.emptyPParamsStrictMaybe) changes) sHash +toGovAction (TreasuryWithdrawals (Map.toList -> withdrawals)) sHash = + (`Conway.TreasuryWithdrawals` sHash) . Map.fromList <$> mapM (\(cred, Api.Lovelace lv) -> (,Cardano.Coin lv) <$> toRewardAccount cred) withdrawals -- | Translates a list of skeleton proposals into a proposal procedures toProposalProcedures :: (MonadBlockChainBalancing m) => [TxSkelProposal] -> - AnchorResolution -> m (Cardano.TxProposalProcedures Cardano.BuildTx Cardano.ConwayEra) -toProposalProcedures props _ | null props = return Cardano.TxProposalProceduresNone -toProposalProcedures props anchorResolution = - Cardano.TxProposalProcedures . OMap.fromList <$> mapM (`toProposalProcedureAndWitness` anchorResolution) props +toProposalProcedures props | null props = return Cardano.TxProposalProceduresNone +toProposalProcedures props = + Cardano.TxProposalProcedures . OMap.fromList + <$> forM + props + ( \(TxSkelProposal (Script.toCredential -> returnCredential) govAction mConstitution (toCardanoAnchor -> anchor)) -> do + proposalDeposit <- govActionDeposit + rewardAccount <- toRewardAccount returnCredential + (Cardano.BuildTxWith -> mConstitutionWitness, mConstitutionHash) <- case mConstitution of + Just (UserRedeemedScript (toVScript -> script) redeemer) -> do + scriptWitness <- toScriptWitness script redeemer Cardano.NoScriptDatumForStake + Cardano.ScriptHash scriptHash <- throwOnToCardanoError "Unable to convert script hash" $ Ledger.toCardanoScriptHash $ Script.toScriptHash script + return (Just scriptWitness, SJust scriptHash) + _ -> return (Nothing, SNothing) + cardanoGovAction <- toGovAction govAction mConstitutionHash + return (Conway.ProposalProcedure (Cardano.Coin $ coerce proposalDeposit) rewardAccount cardanoGovAction anchor, mConstitutionWitness) + ) diff --git a/src/Cooked/MockChain/GenerateTx/Withdrawals.hs b/src/Cooked/MockChain/GenerateTx/Withdrawals.hs index ee5129c1..8c86831c 100644 --- a/src/Cooked/MockChain/GenerateTx/Withdrawals.hs +++ b/src/Cooked/MockChain/GenerateTx/Withdrawals.hs @@ -2,14 +2,13 @@ module Cooked.MockChain.GenerateTx.Withdrawals (toWithdrawals) where import Cardano.Api qualified as Cardano -import Cardano.Api.Ledger qualified as Cardano -import Cardano.Api.Shelley qualified as Cardano import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx.Common import Cooked.MockChain.GenerateTx.Witness import Cooked.Skeleton +import Data.Coerce import Data.Map qualified as Map import Ledger.Tx.CardanoAPI qualified as Ledger import Plutus.Script.Utils.Scripts qualified as Script @@ -17,27 +16,20 @@ import PlutusLedgerApi.V1.Value qualified as Api -- | Takes a 'TxSkelWithdrawals' and transforms it into a 'Cardano.TxWithdrawals' toWithdrawals :: (MonadBlockChainBalancing m) => TxSkelWithdrawals -> m (Cardano.TxWithdrawals Cardano.BuildTx Cardano.ConwayEra) -toWithdrawals (Map.toList -> []) = return Cardano.TxWithdrawalsNone -toWithdrawals (Map.toList -> withdrawals) = - fmap - (Cardano.TxWithdrawals Cardano.ShelleyBasedEraConway) - $ forM withdrawals - $ \(staker, (red, Api.Lovelace n)) -> - do - (witness, sCred) <- - case staker of - Right pkh -> do - sCred <- - throwOnToCardanoError "toWithdrawals: unable to translate pkh stake credential" $ - Cardano.StakeCredentialByKey <$> Ledger.toCardanoStakeKeyHash pkh - return (Cardano.KeyWitness Cardano.KeyWitnessForStakeAddr, sCred) - Left script -> do - witness <- - Cardano.ScriptWitness Cardano.ScriptWitnessForStakeAddr - <$> toScriptWitness script red Cardano.NoScriptDatumForStake - sCred <- - throwOnToCardanoError "toWithdrawals: unable to translate script stake credential" $ - Cardano.StakeCredentialByScript <$> Ledger.toCardanoScriptHash (Script.toScriptHash script) - return (witness, sCred) - networkId <- Emulator.pNetworkId <$> getParams - return (Cardano.makeStakeAddress networkId sCred, Cardano.Coin n, Cardano.BuildTxWith witness) +toWithdrawals withdrawal | withdrawal == mempty = return Cardano.TxWithdrawalsNone +toWithdrawals (TxSkelWithdrawals (Map.toList -> pkWithdrawals) (Map.toList -> scriptWithdrawals)) = do + networkId <- Emulator.pNetworkId <$> getParams + cardanoPubKeyWithdrawals <- forM pkWithdrawals $ \(pkh, amount) -> do + sCred <- + throwOnToCardanoError "toWithdrawals: unable to translate pkh stake credential" $ + Cardano.StakeCredentialByKey <$> Ledger.toCardanoStakeKeyHash pkh + return (Cardano.makeStakeAddress networkId sCred, coerce amount, Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForStakeAddr) + cardanoScriptWithdrawals <- forM scriptWithdrawals $ \(vScript, (red, amount)) -> do + witness <- + Cardano.ScriptWitness Cardano.ScriptWitnessForStakeAddr + <$> toScriptWitness vScript red Cardano.NoScriptDatumForStake + sCred <- + throwOnToCardanoError "toWithdrawals: unable to translate script stake credential" $ + Cardano.StakeCredentialByScript <$> Ledger.toCardanoScriptHash (Script.toScriptHash vScript) + return (Cardano.makeStakeAddress networkId sCred, coerce amount, Cardano.BuildTxWith witness) + return $ Cardano.TxWithdrawals Cardano.ShelleyBasedEraConway (cardanoPubKeyWithdrawals <> cardanoScriptWithdrawals) diff --git a/src/Cooked/MockChain/GenerateTx/Witness.hs b/src/Cooked/MockChain/GenerateTx/Witness.hs index 4a08ef1e..310a5c40 100644 --- a/src/Cooked/MockChain/GenerateTx/Witness.hs +++ b/src/Cooked/MockChain/GenerateTx/Witness.hs @@ -1,13 +1,26 @@ -- | This module exposes the generation of witnesses and reward account module Cooked.MockChain.GenerateTx.Witness ( toRewardAccount, + toCardanoCredential, toScriptWitness, toKeyWitness, + toStakeCredential, + deserialiseFromBuiltinByteString, + toScriptHash, + toKeyHash, + toDRepCredential, + toStakePoolKeyHash, + toColdCredential, + toHotCredential, + toVRFVerKeyHash, ) where +import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano -import Cardano.Api.Shelley qualified as Cardano hiding (Testnet) +import Cardano.Ledger.BaseTypes qualified as C.Ledger +import Cardano.Ledger.Hashes qualified as C.Ledger +import Cardano.Ledger.Shelley.API qualified as C.Ledger import Control.Monad.Except (throwError) import Cooked.MockChain.BlockChain import Cooked.MockChain.GenerateTx.Common @@ -20,28 +33,77 @@ import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api -- | Translates a given credential to a reward account. -toRewardAccount :: (MonadBlockChainBalancing m) => Api.Credential -> m Cardano.RewardAccount -toRewardAccount cred = - Cardano.RewardAccount Cardano.Testnet <$> case cred of - Api.ScriptCredential scriptHash -> do - Cardano.ScriptHash cHash <- - throwOnToCardanoError - "toRewardAccount: Unable to convert script hash." - (Ledger.toCardanoScriptHash scriptHash) - return $ Cardano.ScriptHashObj cHash - Api.PubKeyCredential pubkeyHash -> do - Cardano.StakeKeyHash pkHash <- - throwOnToCardanoError - "toRewardAccount: Unable to convert private key hash." - (Ledger.toCardanoStakeKeyHash pubkeyHash) - return $ Cardano.KeyHashObj pkHash +toRewardAccount :: (MonadBlockChainBalancing m) => Api.Credential -> m C.Ledger.RewardAccount +toRewardAccount = (C.Ledger.RewardAccount C.Ledger.Testnet <$>) . toCardanoCredential Cardano.AsStakeKey Cardano.unStakeKeyHash + +-- TODO: if this works, migrate to plutus-ledger + +-- | Converts an 'Api.PubKeyHash' to any kind of key +deserialiseFromBuiltinByteString :: + (MonadBlockChainBalancing m, Cardano.SerialiseAsRawBytes a) => + Cardano.AsType a -> + Api.BuiltinByteString -> + m a +deserialiseFromBuiltinByteString asType = + throwOnToCardanoError "deserialiseFromBuiltinByteString" . Ledger.deserialiseFromRawBytes asType . Api.fromBuiltin + +-- | Converts a plutus script hash into a cardano ledger script hash +toScriptHash :: (MonadBlockChainBalancing m) => Api.ScriptHash -> m C.Ledger.ScriptHash +toScriptHash (Api.ScriptHash sHash) = do + Cardano.ScriptHash cHash <- deserialiseFromBuiltinByteString Cardano.AsScriptHash sHash + return cHash + +-- | Converts a plutus pkhash into a certain cardano ledger hash +toKeyHash :: + (MonadBlockChainBalancing m, Cardano.SerialiseAsRawBytes (Cardano.Hash key)) => + Cardano.AsType key -> + (Cardano.Hash key -> C.Ledger.KeyHash kr) -> + Api.PubKeyHash -> + m (C.Ledger.KeyHash kr) +toKeyHash asType unwrap = fmap unwrap . deserialiseFromBuiltinByteString (Cardano.AsHash asType) . Api.getPubKeyHash + +-- | Converts an 'Api.PubKeyHash' into a cardano ledger stake pool key hash +toStakePoolKeyHash :: (MonadBlockChainBalancing m) => Api.PubKeyHash -> m (C.Ledger.KeyHash 'C.Ledger.StakePool) +toStakePoolKeyHash = toKeyHash Cardano.AsStakePoolKey Cardano.unStakePoolKeyHash + +-- | Converts an 'Api.PubKeyHash' into a cardano ledger VRFVerKeyHash +toVRFVerKeyHash :: (MonadBlockChainBalancing m) => Api.PubKeyHash -> m (C.Ledger.VRFVerKeyHash a) +toVRFVerKeyHash (Api.PubKeyHash pkh) = do + Cardano.VrfKeyHash key <- deserialiseFromBuiltinByteString (Cardano.AsHash Cardano.AsVrfKey) pkh + return $ Cardano.toVRFVerKeyHash key + +-- | Converts an 'Api.Credential' to a Cardano Credential of the expected kind +toCardanoCredential :: + (MonadBlockChainBalancing m, Cardano.SerialiseAsRawBytes (Cardano.Hash key)) => + Cardano.AsType key -> + (Cardano.Hash key -> C.Ledger.KeyHash kr) -> + Api.Credential -> + m (C.Ledger.Credential kr) +toCardanoCredential _ _ (Api.ScriptCredential sHash) = C.Ledger.ScriptHashObj <$> toScriptHash sHash +toCardanoCredential asType unwrap (Api.PubKeyCredential pkHash) = C.Ledger.KeyHashObj <$> toKeyHash asType unwrap pkHash + +-- | Translates a credential into a Cardano stake credential +toStakeCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.Staking) +toStakeCredential = toCardanoCredential Cardano.AsStakeKey Cardano.unStakeKeyHash + +-- | Translates a credential into a Cardano drep credential +toDRepCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.DRepRole) +toDRepCredential = toCardanoCredential Cardano.AsDRepKey Cardano.unDRepKeyHash + +-- | Translates a credential into a Cardano cold committee credential +toColdCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.ColdCommitteeRole) +toColdCredential = toCardanoCredential Cardano.AsCommitteeColdKey Cardano.unCommitteeColdKeyHash + +-- | Translates a credential into a Cardano hot committee credential +toHotCredential :: (MonadBlockChainBalancing m) => Api.Credential -> m (C.Ledger.Credential 'C.Ledger.HotCommitteeRole) +toHotCredential = toCardanoCredential Cardano.AsCommitteeHotKey Cardano.unCommitteeHotKeyHash -- | Translates a script and a reference script utxo into either a plutus script -- or a reference input containing the right script -toPlutusScriptOrReferenceInput :: (MonadBlockChainBalancing m) => Script.Versioned Script.Script -> Maybe Api.TxOutRef -> m (Cardano.PlutusScriptOrReferenceInput lang) +toPlutusScriptOrReferenceInput :: (MonadBlockChainBalancing m) => VScript -> Maybe Api.TxOutRef -> m (Cardano.PlutusScriptOrReferenceInput lang) toPlutusScriptOrReferenceInput (Script.Versioned (Script.Script script) _) Nothing = return $ Cardano.PScript $ Cardano.PlutusScriptSerialised script toPlutusScriptOrReferenceInput (Script.toScriptHash -> scriptHash) (Just scriptOutRef) = do - (preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptHashAF) -> mScriptHash) <- txSkelOutByRef scriptOutRef + (preview txSkelOutReferenceScriptHashAF -> mScriptHash) <- txSkelOutByRef scriptOutRef case mScriptHash of Just scriptHash' | scriptHash == scriptHash' -> @@ -56,8 +118,8 @@ toPlutusScriptOrReferenceInput (Script.toScriptHash -> scriptHash) (Just scriptO -- the transaction create, we cannot know the execution units used by the -- script. They will be filled out later on once the full body has been -- generated. So, for now, we temporarily leave them to 0. -toScriptWitness :: (MonadBlockChainBalancing m, Script.ToVersioned Script.Script a) => a -> TxSkelRedeemer -> Cardano.ScriptDatum b -> m (Cardano.ScriptWitness b Cardano.ConwayEra) -toScriptWitness (Script.toVersioned -> script@(Script.Versioned _ version)) (TxSkelRedeemer {..}) datum = do +toScriptWitness :: (MonadBlockChainBalancing m, ToVScript a) => a -> TxSkelRedeemer -> Cardano.ScriptDatum b -> m (Cardano.ScriptWitness b Cardano.ConwayEra) +toScriptWitness (toVScript -> script@(Script.Versioned _ version)) (TxSkelRedeemer {..}) datum = do let scriptData = Ledger.toCardanoScriptData $ Api.toBuiltinData txSkelRedeemerContent case version of Script.PlutusV1 -> diff --git a/src/Cooked/MockChain/MinAda.hs b/src/Cooked/MockChain/MinAda.hs index 704cb931..bab7dd7e 100644 --- a/src/Cooked/MockChain/MinAda.hs +++ b/src/Cooked/MockChain/MinAda.hs @@ -8,8 +8,6 @@ module Cooked.MockChain.MinAda where import Cardano.Api qualified as Cardano -import Cardano.Api.Ledger qualified as Cardano -import Cardano.Api.Shelley qualified as Cardano import Cardano.Ledger.Shelley.Core qualified as Shelley import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad diff --git a/src/Cooked/MockChain/MockChainState.hs b/src/Cooked/MockChain/MockChainState.hs index ce57aa67..39c3d4b3 100644 --- a/src/Cooked/MockChain/MockChainState.hs +++ b/src/Cooked/MockChain/MockChainState.hs @@ -21,20 +21,23 @@ import Data.Map.Strict qualified as Map import Ledger.Orphans () import Optics.Core import Optics.TH -import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api -- | The state used to run the simulation in 'Cooked.MockChain.Direct' -data MockChainState = MockChainState - { mcstParams :: Emulator.Params, - mcstLedgerState :: Emulator.EmulatedLedgerState, - -- | Associates to each 'Api.TxOutRef' the 'TxSkelOut' that produced it, - -- alongside a boolean to state whether this UTxO is still present in the - -- index ('True') or has already been consumed ('False'). - mcstOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), - -- | The constitution script to be used with proposals - mcstConstitution :: Maybe (Script.Versioned Script.Script) - } +data MockChainState where + MockChainState :: + { -- | The parametors of the emulated blockchain + mcstParams :: Emulator.Params, + -- | The ledger state of the emulated blockchain + mcstLedgerState :: Emulator.EmulatedLedgerState, + -- | Associates to each 'Api.TxOutRef' the 'TxSkelOut' that produced it, + -- alongside a boolean to state whether this UTxO is still present in the + -- index ('True') or has already been consumed ('False'). + mcstOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), + -- | The constitution script to be used with proposals + mcstConstitution :: Maybe VScript + } -> + MockChainState deriving (Show) -- | A lens to set or get the parameters of the 'MockChainState' @@ -69,7 +72,7 @@ mcstToUtxoState = NoTxSkelOutDatum -> NoUtxoPayloadDatum SomeTxSkelOutDatum content kind -> SomeUtxoPayloadDatum content (kind /= Inline) ) - (preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptHashAF) txSkelOut) + (preview txSkelOutReferenceScriptHashAF txSkelOut) ] in if bool then utxoState {availableUtxos = Map.insertWith (<>) newAddress newPayloadSet (availableUtxos utxoState)} diff --git a/src/Cooked/MockChain/Staged.hs b/src/Cooked/MockChain/Staged.hs index 1c50202b..f174a239 100644 --- a/src/Cooked/MockChain/Staged.hs +++ b/src/Cooked/MockChain/Staged.hs @@ -36,7 +36,6 @@ import Data.Default import Ledger.Slot qualified as Ledger import Ledger.Tx qualified as Ledger import Plutus.Script.Utils.Address qualified as Script -import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api -- * Interpreting and running 'StagedMockChain' @@ -78,8 +77,8 @@ data MockChainBuiltin a where UtxosAt :: (Script.ToAddress a) => a -> MockChainBuiltin [(Api.TxOutRef, TxSkelOut)] LogEvent :: MockChainLogEntry -> MockChainBuiltin () Define :: (ToHash a) => String -> a -> MockChainBuiltin a - SetConstitutionScript :: (Script.ToVersioned Script.Script s) => s -> MockChainBuiltin () - GetConstitutionScript :: MockChainBuiltin (Maybe (Script.Versioned Script.Script)) + SetConstitutionScript :: (ToVScript s) => s -> MockChainBuiltin () + GetConstitutionScript :: MockChainBuiltin (Maybe VScript) RegisterStakingCred :: (Script.ToCredential c) => c -> Integer -> Integer -> MockChainBuiltin () ForceOutputs :: [TxSkelOut] -> MockChainBuiltin [Api.TxOutRef] -- | The empty set of traces diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index 598a9d3d..e377df67 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/MockChain/UtxoSearch.hs @@ -132,8 +132,8 @@ onlyValueOutputsAtSearch :: (MonadBlockChainBalancing m, Script.ToAddress addr) onlyValueOutputsAtSearch addr = utxosOwnedBySearch addr `filterWithPureRev` preview (txSkelOutDatumL % txSkelOutDatumKindAT) - `filterWithPureRev` view txSkelOutStakingCredentialL - `filterWithPureRev` preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptVersionedP) + `filterWithPureRev` view txSkelOutMStakingCredentialL + `filterWithPureRev` view txSkelOutMReferenceScriptL -- | Same as 'onlyValueOutputsAtSearch', but also ensures the returned outputs -- do not contain non-ADA assets. These "vanilla" outputs are perfect candidates @@ -146,4 +146,4 @@ referenceScriptOutputsSearch :: (MonadBlockChain m, Script.ToScriptHash s) => s -> UtxoSearch m TxSkelOut referenceScriptOutputsSearch s = allUtxosSearch - `filterWithPred` ((Just (Script.toScriptHash s) ==) . preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptHashAF)) + `filterWithPred` ((Just (Script.toScriptHash s) ==) . preview txSkelOutReferenceScriptHashAF) diff --git a/src/Cooked/MockChain/UtxoState.hs b/src/Cooked/MockChain/UtxoState.hs index 30cc139f..055daad7 100644 --- a/src/Cooked/MockChain/UtxoState.hs +++ b/src/Cooked/MockChain/UtxoState.hs @@ -20,10 +20,14 @@ import PlutusLedgerApi.V3 qualified as Api -- | A description of who owns what in a blockchain. Owners are addresses and -- they each own a 'UtxoPayloadSet'. -data UtxoState = UtxoState - { availableUtxos :: Map Api.Address UtxoPayloadSet, - consumedUtxos :: Map Api.Address UtxoPayloadSet - } +data UtxoState where + UtxoState :: + { -- | Utxos available to be consumed + availableUtxos :: Map Api.Address UtxoPayloadSet, + -- | Utxos already consumed + consumedUtxos :: Map Api.Address UtxoPayloadSet + } -> + UtxoState deriving (Eq) -- | Total value accessible to what's pointed by the address. @@ -67,16 +71,18 @@ instance Eq UtxoPayloadDatum where dat == dat' = compare dat dat' == EQ -- | A convenient wrapping of the interesting information of a UTxO. -data UtxoPayload = UtxoPayload - { -- | The reference of this UTxO - utxoPayloadTxOutRef :: Api.TxOutRef, - -- | The value stored in this UTxO - utxoPayloadValue :: Api.Value, - -- | The optional datum stored in this UTxO - utxoPayloadDatum :: UtxoPayloadDatum, - -- | The optional reference script stored in this UTxO - utxoPayloadReferenceScript :: Maybe Api.ScriptHash - } +data UtxoPayload where + UtxoPayload :: + { -- | The reference of this UTxO + utxoPayloadTxOutRef :: Api.TxOutRef, + -- | The value stored in this UTxO + utxoPayloadValue :: Api.Value, + -- | The optional datum stored in this UTxO + utxoPayloadDatum :: UtxoPayloadDatum, + -- | The optional reference script stored in this UTxO + utxoPayloadReferenceScript :: Maybe Api.ScriptHash + } -> + UtxoPayload deriving (Eq, Show) instance Eq UtxoPayloadSet where diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index f7e512a3..ef32aad5 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/src/Cooked/Pretty/Skeleton.hs @@ -15,11 +15,10 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes) import Data.Set qualified as Set +import Ledger.Slot qualified as Ledger import Optics.Core import Plutus.Script.Utils.Address qualified as Script -import Plutus.Script.Utils.Scripts qualified as Script import Plutus.Script.Utils.Value qualified as Script -import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api import Prettyprinter ((<+>)) import Prettyprinter qualified as PP @@ -39,7 +38,7 @@ data Contextualized a = Contextualized -- | Prints a 'Contextualized' 'TxSkel' instance PrettyCookedList (Contextualized TxSkel) where prettyCookedOptListMaybe opts cTxSkel - | TxSkel lbl txopts mints signers validityRange ins insReference outs proposals withdrawals <- ctxContent cTxSkel = + | TxSkel lbl txopts mints signers validityRange ins insReference outs proposals withdrawals certificates <- ctxContent cTxSkel = [ prettyItemizeNonEmpty opts "Labels:" "-" lbl, prettyItemizeNonEmpty opts "Mints:" "-" (view txSkelMintsListI mints), Just $ "Validity interval:" <+> PP.pretty validityRange, @@ -48,22 +47,55 @@ instance PrettyCookedList (Contextualized TxSkel) where prettyItemizeNonEmpty opts "Reference inputs:" "-" $ prettyCookedOpt opts . (<$ cTxSkel) . ReferenceInput <$> Set.toList insReference, prettyItemizeNonEmpty opts "Outputs:" "-" (prettyCookedOpt opts <$> outs), prettyItemizeNonEmpty opts "Proposals:" "-" (prettyItemizeNoTitle opts "-" <$> proposals), - prettyItemizeNonEmpty opts "Withdrawals:" "-" (mkWithdrawal <$> Map.toList withdrawals), + prettyItemizeNonEmpty opts "Withdrawals:" "-" $ view txSkelWithdrawalsListI withdrawals, + prettyItemizeNonEmpty opts "Certificates:" "-" certificates, prettyItemizeNonEmpty opts "Options:" "-" txopts ] -data Withdrawal = Withdrawal (Either (Script.Versioned Script.Script) Api.PubKeyHash) TxSkelRedeemer Api.Lovelace +instance PrettyCooked TxSkelCertificate where + prettyCookedOpt opts (TxSkelCertificate owner action) = + prettyItemize + opts + (prettyCookedOpt opts action) + "-" + $ prettyCookedList owner + +instance PrettyCookedList (User req mode) where + prettyCookedOptListMaybe opt (UserPubKey (Script.toPubKeyHash -> pkh)) = [Just ("User" <+> prettyHash opt pkh)] + prettyCookedOptListMaybe opt (UserScript (toVScript -> vScript)) = [Just ("Script" <+> prettyHash opt vScript)] + prettyCookedOptListMaybe opt (UserRedeemedScript (toVScript -> script) red) = + Just (prettyHash opt script) : prettyCookedOptListMaybe opt red + +instance PrettyCooked (CertificateAction req) where + prettyCookedOpt _ StakingRegister = "Register staking" + prettyCookedOpt _ StakingUnRegister = "Unregister staking" + prettyCookedOpt opt (StakingDelegate deleg) = "Delegate staking to" <+> prettyCookedOpt opt deleg + prettyCookedOpt opt (StakingRegisterDelegate deleg) = "Register staking and delegate it to" <+> prettyCookedOpt opt deleg + prettyCookedOpt _ DRepRegister = "Register DRep" + prettyCookedOpt _ DRepUpdate = "Update DRep" + prettyCookedOpt _ DRepUnRegister = "Unregister DRep" + prettyCookedOpt opt (PoolRegister poolVfr) = "Register pool" <+> prettyHash opt poolVfr + prettyCookedOpt _ (PoolRetire (Ledger.Slot n)) = "Retire pool at slot" <+> PP.pretty n + prettyCookedOpt opt (CommitteeRegisterHot cred) = "Register hot credential" <+> prettyCookedOpt opt cred + prettyCookedOpt _ CommitteeResign = "Resign committee" + +instance PrettyCooked Api.Delegatee where + prettyCookedOpt opt (Api.DelegStake pkh) = "Delegate stake to" <+> prettyHash opt pkh + prettyCookedOpt opt (Api.DelegVote dRep) = "Delegate vote to" <+> prettyCookedOpt opt dRep + prettyCookedOpt opt (Api.DelegStakeVote pkh dRep) = "Delegate stake to" <+> prettyHash opt pkh <+> "and delegate vote to" <+> prettyCookedOpt opt dRep -mkWithdrawal :: (Either (Script.Versioned Script.Script) Api.PubKeyHash, (TxSkelRedeemer, Api.Lovelace)) -> Withdrawal -mkWithdrawal (owner, (red, lv)) = Withdrawal owner red lv +instance PrettyCooked Api.DRep where + prettyCookedOpt _ Api.DRepAlwaysAbstain = "Always abstain" + prettyCookedOpt _ Api.DRepAlwaysNoConfidence = "Always no confidence" + prettyCookedOpt opt (Api.DRep (Api.DRepCredential cred)) = prettyCookedOpt opt cred instance PrettyCooked Withdrawal where - prettyCookedOpt opts (Withdrawal (Left script) red lv) = - prettyItemize opts (prettyHash opts script) "-" $ prettyCookedOptList opts red ++ [prettyCookedOpt opts (Script.toValue lv)] - prettyCookedOpt opts (Withdrawal (Right pkh) _ lv) = + prettyCookedOpt opts (Withdrawal (UserRedeemedScript (toVScript -> vScript) red) lv) = + prettyItemize opts (prettyHash opts vScript) "-" $ prettyCookedOptList opts red ++ [prettyCookedOpt opts (Script.toValue lv)] + prettyCookedOpt opts (Withdrawal (UserPubKey (Script.toPubKeyHash -> pkh)) lv) = prettyItemize opts (prettyHash opts pkh) "-" [prettyCookedOpt opts (Script.toValue lv)] -instance PrettyCooked TxParameterChange where +instance PrettyCooked ParameterChange where prettyCookedOpt opts (FeePerByte n) = "Fee per byte:" <+> prettyCookedOpt opts n prettyCookedOpt opts (FeeFixed n) = "Fee fixed:" <+> prettyCookedOpt opts n prettyCookedOpt opts (MaxBlockBodySize n) = "Max block body size:" <+> prettyCookedOpt opts n @@ -141,7 +173,6 @@ instance PrettyCooked TxParameterChange where prettyCookedOpt opts (DRepActivity n) = "DRep activity:" <+> prettyCookedOpt opts n prettyCookedOpt opts (MinFeeRefScriptCostPerByte q) = "Min fee per byto of reference script:" <+> prettyCookedOpt opts q --- | Prints a list of docs corresponding to an instance of 'TxSkelRedeemer' instance PrettyCookedList TxSkelRedeemer where prettyCookedOptListMaybe opts (TxSkelRedeemer red mRefScript _) = [ Just $ "Redeemer" <+> prettyCookedOpt opts red, @@ -149,22 +180,23 @@ instance PrettyCookedList TxSkelRedeemer where ] instance PrettyCookedList TxSkelProposal where - prettyCookedOptListMaybe opts TxSkelProposal {..} = - [ Just $ "Governance action:" <+> prettyCookedOpt opts txSkelProposalAction, - Just $ "Return address:" <+> prettyCooked txSkelProposalAddress, - (\(script, redeemer) -> prettyItemize opts "Witness:" "-" (prettyHash opts script : prettyCookedOptList opts redeemer)) <$> txSkelProposalWitness, - ("Anchor:" <+>) . PP.pretty <$> txSkelProposalAnchor + prettyCookedOptListMaybe opts txSkelProposal = + [ Just $ "Return credential:" <+> prettyCookedOpt opts (view txSkelProposalReturnCredentialL txSkelProposal), + ("Witnessed governance action:" <+>) . prettyCookedOpt opts <$> preview (txSkelProposalGovernanceActionAT @IsScript) txSkelProposal, + ("Other governance action:" <+>) . prettyCookedOpt opts <$> preview (txSkelProposalGovernanceActionAT @IsNone) txSkelProposal, + ("Constitution witness:" <+>) . prettyHash opts <$> preview (txSkelProposalMConstitutionAT % _Just % userVScriptL) txSkelProposal ] + ++ maybe [] (prettyCookedOptListMaybe opts) (preview (txSkelProposalMConstitutionAT % _Just % userTxSkelRedeemerL) txSkelProposal) -instance PrettyCooked TxGovAction where - prettyCookedOpt opts (TxGovActionParameterChange params) = prettyItemize opts "Parameter changes:" "-" params - prettyCookedOpt opts (TxGovActionHardForkInitiation (Api.ProtocolVersion major minor)) = +instance PrettyCooked (GovernanceAction a) where + prettyCookedOpt opts (ParameterChange params) = prettyItemize opts "Parameter changes:" "-" params + prettyCookedOpt opts (HardForkInitiation (Api.ProtocolVersion major minor)) = "Protocol version:" <+> "(" <+> prettyCookedOpt opts major <+> "," <+> prettyCookedOpt opts minor <+> ")" - prettyCookedOpt opts (TxGovActionTreasuryWithdrawals withdrawals) = + prettyCookedOpt opts (TreasuryWithdrawals withdrawals) = prettyItemize opts "Withdrawals:" "-" $ (\(cred, lv) -> prettyCookedOpt opts cred <+> "|" <+> prettyCooked (Script.toValue lv)) <$> Map.toList withdrawals - prettyCookedOpt _ TxGovActionNoConfidence = "No confidence" - prettyCookedOpt opts (TxGovActionUpdateCommittee toRemoveCreds toAddCreds quorum) = + prettyCookedOpt _ NoConfidence = "No confidence" + prettyCookedOpt opts (UpdateCommittee toRemoveCreds toAddCreds quorum) = prettyItemize opts "Updates in committee:" @@ -175,7 +207,7 @@ instance PrettyCooked TxGovAction where (\(Api.ColdCommitteeCredential cred, i) -> prettyCookedOpt opts cred <+> "->" <+> prettyCookedOpt opts i) <$> Map.toList toAddCreds, "Quorum:" <+> prettyCookedOpt opts (Api.toGHC quorum) ] - prettyCookedOpt opts (TxGovActionNewConstitution (Api.Constitution mScriptHash)) = case mScriptHash of + prettyCookedOpt opts (NewConstitution (Api.Constitution mScriptHash)) = case mScriptHash of Nothing -> "Empty new constitution" Just sHash -> "New constitution:" <+> prettyHash opts sHash @@ -198,8 +230,8 @@ instance PrettyCookedList (TxSkelOpts, [Wallet]) where -- - "Foo": 500 -- - "Bar": 1000 instance PrettyCooked Mint where - prettyCookedOpt opts (Mint pol red tks) = - prettyItemize opts (prettyHash opts (Script.toVersioned @Script.MintingPolicy pol)) "-" $ + prettyCookedOpt opts (Mint (UserRedeemedScript pol red) tks) = + prettyItemize opts (prettyHash opts (toVScript pol)) "-" $ prettyCookedOptList opts red ++ ((\(tk, n) -> PP.viaShow tk <> ":" <+> PP.viaShow n) <$> tks) instance PrettyCookedList TxSkelOut where @@ -209,7 +241,7 @@ instance PrettyCookedList TxSkelOut where ] ++ catMaybes [ prettyCookedOptMaybe opts (output ^. txSkelOutDatumL), - ("Reference script hash:" <+>) . prettyHash opts <$> preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptHashAF) output + ("Reference script hash:" <+>) . prettyHash opts <$> preview txSkelOutReferenceScriptHashAF output ] instance PrettyCooked TxSkelOut where @@ -256,15 +288,13 @@ instance PrettyCookedList TxSkelOpts where txSkelOptBalancingUtxos _ txSkelOptCollateralUtxos - txSkelOptAnchorResolution ) = [ prettyIfNot True prettyAutoSlotIncrease txSkelOptAutoSlotIncrease, prettyIfNot def prettyBalanceOutputPolicy txSkelOptBalanceOutputPolicy, prettyIfNot def prettyBalanceFeePolicy txSkelOptFeePolicy, prettyIfNot def prettyBalancingPolicy txSkelOptBalancingPolicy, prettyIfNot def prettyBalancingUtxos txSkelOptBalancingUtxos, - prettyIfNot def prettyCollateralUtxos txSkelOptCollateralUtxos, - prettyIfNot def prettyAnchorResolution txSkelOptAnchorResolution + prettyIfNot def prettyCollateralUtxos txSkelOptCollateralUtxos ] where prettyIfNot :: (Eq a) => a -> (a -> DocCooked) -> a -> Maybe DocCooked @@ -313,10 +343,6 @@ instance PrettyCookedList TxSkelOpts where prettyBalanceFeePolicy :: FeePolicy -> DocCooked prettyBalanceFeePolicy AutoFeeComputation = "Use automatically computed fee" prettyBalanceFeePolicy (ManualFee fee) = "Use the following fee:" <+> prettyCookedOpt opts fee - prettyAnchorResolution :: AnchorResolution -> DocCooked - prettyAnchorResolution AnchorResolutionHttp = "Resolve anchor url with an (unsafe) http connection" - prettyAnchorResolution (AnchorResolutionLocal urlMap) = - prettyItemize @[DocCooked] opts "Resolve anchor url with the following table keys" "-" (PP.viaShow <$> Map.keys urlMap) -- | Resolves a "TxOutRef" from a given context, builds a doc cooked for its -- address and value, and also builds a possibly empty list for its datum and diff --git a/src/Cooked/Skeleton.hs b/src/Cooked/Skeleton.hs index 3bf839c0..7ff2cb81 100644 --- a/src/Cooked/Skeleton.hs +++ b/src/Cooked/Skeleton.hs @@ -25,6 +25,7 @@ module Cooked.Skeleton txSkelInsReferenceL, txSkelOutsL, txSkelWithdrawalsL, + txSkelCertificatesL, txSkelTemplate, txSkelKnownTxOutRefs, txSkelWithdrawnValue, @@ -33,30 +34,32 @@ module Cooked.Skeleton txSkelInsReferenceInRedeemers, txSkelProposingScripts, txSkelMintingScripts, + txSkelCertifyingScripts, ) where +import Cooked.Skeleton.Anchor as X +import Cooked.Skeleton.Certificate as X import Cooked.Skeleton.Datum as X import Cooked.Skeleton.Label as X import Cooked.Skeleton.Mint as X import Cooked.Skeleton.Option as X import Cooked.Skeleton.Output as X -import Cooked.Skeleton.Payable as X import Cooked.Skeleton.Proposal as X import Cooked.Skeleton.Redeemer as X -import Cooked.Skeleton.ReferenceScript as X +import Cooked.Skeleton.User as X +import Cooked.Skeleton.Value as X import Cooked.Skeleton.Withdrawal as X import Cooked.Wallet import Data.Default import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe import Data.Set (Set) import Data.Set qualified as Set import Ledger.Slot qualified as Ledger import Optics.Core import Optics.TH -import Plutus.Script.Utils.Scripts qualified as Script +import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api -- | A transaction skeleton. This is cooked-validators's variant of transaction @@ -65,7 +68,7 @@ data TxSkel where TxSkel :: { -- | Labels do not influence the transaction generation at all; they are -- pretty-printed whenever cooked-validators prints a transaction, and can - -- therefore make the output more informative (and greppable). + -- therefore make the output more informative. txSkelLabel :: Set TxSkelLabel, -- | Some options that control transaction generation. txSkelOpts :: TxSkelOpts, @@ -100,41 +103,48 @@ data TxSkel where -- possible enacted later on. txSkelProposals :: [TxSkelProposal], -- | Withdrawals performed by the transaction - txSkelWithdrawals :: TxSkelWithdrawals + txSkelWithdrawals :: TxSkelWithdrawals, + -- | Certificates issued by the transaction + txSkelCertificates :: [TxSkelCertificate] } -> TxSkel deriving (Show, Eq) --- | A lens to set of get labels from a 'TxSkel' +-- | Focusing on the labels of a 'TxSkel' makeLensesFor [("txSkelLabel", "txSkelLabelL")] ''TxSkel --- | A lens to set of get options from a 'TxSkel' +-- | Focusing on the optics of a 'TxSkel' makeLensesFor [("txSkelOpts", "txSkelOptsL")] ''TxSkel --- | A lens to set of get the minted value of a 'TxSkel' +-- | Focusing on the minted value of a 'TxSkel' makeLensesFor [("txSkelMints", "txSkelMintsL")] ''TxSkel --- | A lens to set of get the validity range of a 'TxSkel' +-- | Focusing on the validity range of a 'TxSkel' makeLensesFor [("txSkelValidityRange", "txSkelValidityRangeL")] ''TxSkel --- | A lens to set of get signers from a 'TxSkel' +-- | Focusing on the signers of a 'TxSkel' makeLensesFor [("txSkelSigners", "txSkelSignersL")] ''TxSkel --- | A lens to set of get inputs from a 'TxSkel' +-- | Focusing on the inputs of a 'TxSkel' makeLensesFor [("txSkelIns", "txSkelInsL")] ''TxSkel --- | A lens to set of get reference inputs from a 'TxSkel' +-- | Focusing on the reference inputs of a 'TxSkel' makeLensesFor [("txSkelInsReference", "txSkelInsReferenceL")] ''TxSkel --- | A lens to set of get outputs from a 'TxSkel' +-- | Focusing on the outputs of a 'TxSkel' makeLensesFor [("txSkelOuts", "txSkelOutsL")] ''TxSkel --- | A lens to set of get proposals from a 'TxSkel' +-- | Focusing on the proposals of a 'TxSkel' makeLensesFor [("txSkelProposals", "txSkelProposalsL")] ''TxSkel --- | A lens to set of get withdrawals from a 'TxSkel' +-- | Focusing on the withdrawals of a 'TxSkel' makeLensesFor [("txSkelWithdrawals", "txSkelWithdrawalsL")] ''TxSkel +-- | Focusing on the certificates of a 'TxSkel' +makeLensesFor [("txSkelCertificates", "txSkelCertificatesL")] ''TxSkel + +-- | A lens to set or + -- | A convenience template of an empty transaction skeleton. txSkelTemplate :: TxSkel txSkelTemplate = @@ -148,7 +158,8 @@ txSkelTemplate = txSkelInsReference = Set.empty, txSkelOuts = [], txSkelProposals = [], - txSkelWithdrawals = Map.empty + txSkelWithdrawals = def, + txSkelCertificates = [] } -- | Returns the full value contained in the skeleton outputs @@ -159,11 +170,11 @@ txSkelValueInOutputs = foldOf (txSkelOutsL % folded % txSkelOutValueL) txSkelInsReferenceInRedeemers :: TxSkel -> Set Api.TxOutRef txSkelInsReferenceInRedeemers TxSkel {..} = Set.fromList $ - mapMaybe txSkelRedeemerReferenceInput $ - Map.elems txSkelIns - <> (snd <$> mapMaybe txSkelProposalWitness txSkelProposals) - <> (fst <$> Map.elems txSkelMints) - <> (fst <$> Map.elems txSkelWithdrawals) + toListOf (to Map.elems % traversed % txSkelRedeemerReferenceInputAT) txSkelIns + <> toListOf (traversed % txSkelProposalMConstitutionAT % _Just % userTxSkelRedeemerL % txSkelRedeemerReferenceInputAT) txSkelProposals + <> toListOf (to Map.elems % traversed % _1 % txSkelRedeemerReferenceInputAT) txSkelMints + <> toListOf (txSkelWithdrawalsByScriptsL % to Map.elems % traversed % _1 % txSkelRedeemerReferenceInputAT) txSkelWithdrawals + <> toListOf (traversed % txSkelCertificateOwnerAT % userTxSkelRedeemerL % txSkelRedeemerReferenceInputAT) txSkelCertificates -- | All `Api.TxOutRef`s known by a given transaction skeleton. This includes -- TxOutRef`s used as inputs of the skeleton and 'Api.TxOutRef's used as reference @@ -171,23 +182,24 @@ txSkelInsReferenceInRedeemers TxSkel {..} = -- 'Api.TxOutRef's used for balancing and additional 'Api.TxOutRef's used as collateral -- inputs, as they are not part of the skeleton. txSkelKnownTxOutRefs :: TxSkel -> Set Api.TxOutRef -txSkelKnownTxOutRefs skel@TxSkel {..} = - txSkelInsReferenceInRedeemers skel - <> Map.keysSet txSkelIns - <> txSkelInsReference +txSkelKnownTxOutRefs skel@TxSkel {..} = txSkelInsReferenceInRedeemers skel <> Map.keysSet txSkelIns <> txSkelInsReference -- | Returns the total value withdrawn in this 'TxSkel' txSkelWithdrawnValue :: TxSkel -> Api.Value -txSkelWithdrawnValue = review valueLovelaceP . foldOf (txSkelWithdrawalsL % to Map.toList % traversed % _2 % _2) +txSkelWithdrawnValue = Script.toValue . txSkelWithdrawals -- | Returns all the scripts involved in withdrawals in this 'TxSkel' -txSkelWithdrawingScripts :: TxSkel -> [Script.Versioned Script.Script] -txSkelWithdrawingScripts = toListOf (txSkelWithdrawalsL % to Map.toList % traversed % _1 % _Left) +txSkelWithdrawingScripts :: TxSkel -> [VScript] +txSkelWithdrawingScripts = toListOf (txSkelWithdrawalsL % txSkelWithdrawalsByScriptsL % to Map.keys % traversed) -- | Returns all the scripts involved in proposals in this 'TxSkel' -txSkelProposingScripts :: TxSkel -> [Script.Versioned Script.Script] -txSkelProposingScripts = toListOf (txSkelProposalsL % traversed % txSkelProposalWitnessL % _Just % _1) +txSkelProposingScripts :: TxSkel -> [VScript] +txSkelProposingScripts = toListOf (txSkelProposalsL % traversed % txSkelProposalMConstitutionAT % _Just % userVScriptL) -- | Returns all the scripts involved in minting in this 'TxSkel' -txSkelMintingScripts :: TxSkel -> [Script.Versioned Script.Script] -txSkelMintingScripts = toListOf (txSkelMintsL % txSkelMintsListI % traversed % mintVersionedScriptL) +txSkelMintingScripts :: TxSkel -> [VScript] +txSkelMintingScripts = toListOf (txSkelMintsL % txSkelMintsListI % traversed % mintRedeemedScriptL % userVScriptL) + +-- | Returns all the scripts involved in certificates in this 'TxSkel' +txSkelCertifyingScripts :: TxSkel -> [VScript] +txSkelCertifyingScripts = toListOf (txSkelCertificatesL % traversed % txSkelCertificateOwnerAT @IsEither % userVScriptAT) diff --git a/src/Cooked/Skeleton/Anchor.hs b/src/Cooked/Skeleton/Anchor.hs new file mode 100644 index 00000000..e1919417 --- /dev/null +++ b/src/Cooked/Skeleton/Anchor.hs @@ -0,0 +1,42 @@ +-- | This module exposes the notion of Anchor used in proposals and +-- certificates. +module Cooked.Skeleton.Anchor + ( -- * Data types + TxSkelAnchor, + + -- * Optics + txSkelAnchorMResolvedPageAT, + txSkelAnchorResolvedPageAT, + txSkelAnchorURLAT, + + -- * Smart constructors + simpleURLAnchor, + ) +where + +import Data.ByteString +import Optics.Core + +-- | A 'TxSkelAnchor' optionally bundles an URL as a String alongside an +-- optional resolved page as a ByteString. +type TxSkelAnchor = + Maybe + ( String, -- The anchor URL + Maybe ByteString -- The optional anchor resolved page + ) + +-- | Focusing on the URL of a 'TxSkelAnchor' +txSkelAnchorURLAT :: AffineTraversal' TxSkelAnchor String +txSkelAnchorURLAT = _Just % _1 + +-- | Focusing on the optional resolved page of a 'TxSkelAnchor' +txSkelAnchorMResolvedPageAT :: AffineTraversal' TxSkelAnchor (Maybe ByteString) +txSkelAnchorMResolvedPageAT = _Just % _2 + +-- | Focusing on the existing resolved page of a 'TxSkelAnchor' +txSkelAnchorResolvedPageAT :: AffineTraversal' TxSkelAnchor ByteString +txSkelAnchorResolvedPageAT = txSkelAnchorMResolvedPageAT % _Just + +-- | Builds a simple Anchor with an URL +simpleURLAnchor :: String -> TxSkelAnchor +simpleURLAnchor = Just . (,Nothing) diff --git a/src/Cooked/Skeleton/Certificate.hs b/src/Cooked/Skeleton/Certificate.hs new file mode 100644 index 00000000..1ea3800d --- /dev/null +++ b/src/Cooked/Skeleton/Certificate.hs @@ -0,0 +1,87 @@ +-- | This module exposes the certificate constructs used in a +-- 'Cooked.Skeleton.TxSkel' and their associated utilities. To emit certificates +-- in a skeleton, the usual way is to invoke @txSkelCertificates = +-- [pubKeyCertificate pk action, scriptCertificate script redeemer action ...]@ +module Cooked.Skeleton.Certificate + ( -- * Data types + CertificateAction (..), + TxSkelCertificate (..), + + -- * Optics + txSkelCertificateOwnerAT, + txSkelCertificateActionAT, + + -- * Smart constructors + pubKeyCertificate, + scriptCertificate, + ) +where + +import Cooked.Skeleton.Families +import Cooked.Skeleton.Redeemer +import Cooked.Skeleton.User +import Data.Kind (Type) +import Data.Typeable (Typeable, cast) +import Ledger.Slot qualified as Ledger +import Optics.Core +import Plutus.Script.Utils.Address qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +-- | The depiction of the possible actions in a certificate. Each actions +-- exposes, in its types, the possible owners it can have. +data CertificateAction :: UserKind -> Type where + StakingRegister :: CertificateAction IsEither + StakingUnRegister :: CertificateAction IsEither + StakingDelegate :: Api.Delegatee -> CertificateAction IsEither + StakingRegisterDelegate :: Api.Delegatee -> CertificateAction IsEither + DRepRegister :: CertificateAction IsEither + DRepUpdate :: CertificateAction IsEither + DRepUnRegister :: CertificateAction IsEither + PoolRegister :: Api.PubKeyHash -> CertificateAction IsPubKey + PoolRetire :: Ledger.Slot -> CertificateAction IsPubKey + CommitteeRegisterHot :: Api.Credential -> CertificateAction IsEither + CommitteeResign :: CertificateAction IsEither + +deriving instance (Show (CertificateAction req)) + +deriving instance (Eq (CertificateAction req)) + +-- | Certificates used in 'Cooked.Skeleton.TxSkel'. The types ensure that each +-- certificate action is associated with a proper owner. +data TxSkelCertificate where + TxSkelCertificate :: + (Typeable kind) => + { -- | All owners of certificates must be in 'Redemption' mode + txSkelCertificateOwner :: User kind Redemption, + -- | The certificate itself does impose a 'UserKind' + txSkelCertificateAction :: CertificateAction kind + } -> + TxSkelCertificate + +deriving instance (Show TxSkelCertificate) + +instance Eq TxSkelCertificate where + (TxSkelCertificate owner action) == (TxSkelCertificate owner' action') = + cast owner == Just owner' && cast action == Just action' + +-- | Focuses on the owner of a 'TxSkelCertificate' +txSkelCertificateOwnerAT :: (Typeable user) => AffineTraversal' TxSkelCertificate (User user Redemption) +txSkelCertificateOwnerAT = + atraversal + (\cert@(TxSkelCertificate {txSkelCertificateOwner}) -> maybe (Left cert) Right $ cast txSkelCertificateOwner) + (\cert@(TxSkelCertificate @user' _ action) -> maybe cert (`TxSkelCertificate` action) . cast @_ @(User user' Redemption)) + +-- | Focuses on the action of a 'TxSkelCertificate' +txSkelCertificateActionAT :: (Typeable user) => AffineTraversal' TxSkelCertificate (CertificateAction user) +txSkelCertificateActionAT = + atraversal + (\cert@(TxSkelCertificate {txSkelCertificateAction}) -> maybe (Left cert) Right $ cast txSkelCertificateAction) + (\cert@(TxSkelCertificate @user' owner _) -> maybe cert (TxSkelCertificate owner) . cast @_ @(CertificateAction user')) + +-- | Smart constructor for a pubkey certificate +pubKeyCertificate :: (Script.ToPubKeyHash pkh, Typeable pkh, Typeable a, a ∈ '[IsPubKey, IsEither]) => pkh -> CertificateAction a -> TxSkelCertificate +pubKeyCertificate pkh = TxSkelCertificate (UserPubKey pkh) + +-- | Smart constructor for a script certificate +scriptCertificate :: (ToVScript script, Typeable script, RedeemerConstrs red) => script -> red -> CertificateAction IsEither -> TxSkelCertificate +scriptCertificate script red = TxSkelCertificate (UserRedeemedScript script (someTxSkelRedeemer red)) diff --git a/src/Cooked/Skeleton/Datum.hs b/src/Cooked/Skeleton/Datum.hs index c963abb2..b3ae02d6 100644 --- a/src/Cooked/Skeleton/Datum.hs +++ b/src/Cooked/Skeleton/Datum.hs @@ -1,10 +1,16 @@ --- | This module exposes the notion of datums as they are handled within a --- 'Cooked.Skeleton.TxSkel' +-- | This module exposes the datum constructs used in payments of a +-- 'Cooked.Skeleton.TxSkel'. Smart constructors for datums can be found in the +-- 'Cooked.Skeleton.Output.Payable' structure meant to build payments. module Cooked.Skeleton.Datum - ( DatumConstrs, + ( -- * Type constraints + DatumConstrs, + + -- * Data types DatumResolved (..), DatumKind (..), TxSkelOutDatum (..), + + -- * Optics datumKindResolvedP, txSkelOutDatumKindAT, txSkelOutDatumResolvedAT, @@ -76,6 +82,11 @@ data TxSkelOutDatum where deriving instance Show TxSkelOutDatum +instance Eq TxSkelOutDatum where + NoTxSkelOutDatum == NoTxSkelOutDatum = True + (SomeTxSkelOutDatum (Api.toBuiltinData -> dat) b) == (SomeTxSkelOutDatum (Api.toBuiltinData -> dat') b') = (dat, b) == (dat', b') + _ == _ = False + instance Ord TxSkelOutDatum where compare NoTxSkelOutDatum NoTxSkelOutDatum = EQ compare NoTxSkelOutDatum _ = LT @@ -85,9 +96,6 @@ instance Ord TxSkelOutDatum where (SomeTxSkelOutDatum (Api.toBuiltinData -> dat') b') = compare (dat, b) (dat', b') -instance Eq TxSkelOutDatum where - dat == dat' = compare dat dat' == EQ - -- * Optics working on 'TxSkelOutDatum' -- | Extracts or changes the 'DatumKind' of a 'TxSkelOutDatum' diff --git a/src/Cooked/Skeleton/Families.hs b/src/Cooked/Skeleton/Families.hs new file mode 100644 index 00000000..cb0f559f --- /dev/null +++ b/src/Cooked/Skeleton/Families.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | This module exposes some type families used to either directly constraint +-- values within our skeletons, or constrant inputs of smart constructors for +-- components of these skeletons. +module Cooked.Skeleton.Families + ( -- * Type-level constraints + type (∈), + type (∉), + type (⩀), + + -- * Type-level functions + type (∪), + type Rev, + type (++), + ) +where + +import Data.Kind +import GHC.TypeLits + +-- | Reverses a type level with an accumulator +type family RevAux (els :: [a]) (done :: [a]) :: [a] where + RevAux '[] done = done + RevAux (x ': xs) done = RevAux xs (x ': done) + +-- | Reverses a type level list starting with an empty accumulator +type Rev els = RevAux els '[] + +-- | Type level append +type family (++) (els :: [a]) (els' :: [a]) :: [a] where + '[] ++ els' = els' + (x ': xs) ++ els' = (x ': xs ++ els') + +-- | Type level list union with duplicates +type family (∪) (xs :: [a]) (ys :: [a]) :: [a] where + '[] ∪ ys = ys + (x ': xs) ∪ ys = x ': (xs ∪ ys) + +-- | A type family representing membership. This requires @UndecidableInstances@ +-- because the type checker is not smart enough to understand that this type +-- family decreases in @els@, due to the presence of @extras@. @extras@ is used +-- to keep track of the original list and output a relevant message in the empty +-- case, which could otherwise be omitted altogther at no loss of type safety. +type family Member (el :: a) (els :: [a]) (extras :: [a]) :: Constraint where + Member x (x ': xs) _ = () + Member x (y ': xs) l = Member x xs (y ': l) + Member x '[] l = TypeError ('ShowType x ':<>: 'Text " is not a member of " ':<>: 'ShowType (Rev l)) + +-- | Type level list membership +type (∈) el els = Member el els '[] + +-- | A type family representing non membership. @extra@ is used to keep track of +-- the already browsed to output a relevant message. It could be omitted with no +-- loss of type safety. +type family NonMember (el :: a) (els :: [a]) (extras :: [a]) :: Constraint where + NonMember x '[] _ = () + NonMember x (x ': xs) extras = TypeError ('ShowType x ':<>: 'Text " is already a member of " ':<>: 'ShowType (Rev extras ++ (x ': xs))) + NonMember x (x' ': xs) extras = NonMember x xs (x' ': extras) + +-- | Type level list non-membership +type (∉) el els = NonMember el els '[] + +-- | Type level disjunction check between lists +type family (⩀) (els :: [a]) (els' :: [a]) :: Constraint where + '[] ⩀ _ = () + (x ': xs) ⩀ ys = (x ∉ ys, xs ⩀ ys) diff --git a/src/Cooked/Skeleton/Label.hs b/src/Cooked/Skeleton/Label.hs index 26f02146..71418cc2 100644 --- a/src/Cooked/Skeleton/Label.hs +++ b/src/Cooked/Skeleton/Label.hs @@ -1,8 +1,13 @@ --- | This module exposes the labels that can be used to stamp +-- | This module exposes the labels that can be used to stamp a -- 'Cooked.Skeleton.TxSkel' with additional arbitrary pieces of information. module Cooked.Skeleton.Label - ( LabelConstrs, + ( -- * Type constraints + LabelConstrs, + + -- * Data types TxSkelLabel (..), + + -- * Optics txSkelLabelTypedP, ) where diff --git a/src/Cooked/Skeleton/Mint.hs b/src/Cooked/Skeleton/Mint.hs index dfe8e082..1ae4ec6b 100644 --- a/src/Cooked/Skeleton/Mint.hs +++ b/src/Cooked/Skeleton/Mint.hs @@ -1,24 +1,31 @@ {-# OPTIONS_GHC -Wno-orphans #-} -- | This module exposes the minting constructs used in a --- 'Cooked.Skeleton.TxSkel' and their associated utilities. +-- 'Cooked.Skeleton.TxSkel' and their associated utilities. To mint or burn +-- tokens in a skeleton, the usual way is to invoke @txSkelMints = +-- txSkelMintsFromList [mint script redeemer token quantity, burn ...]@ module Cooked.Skeleton.Mint - ( TxSkelMints, + ( -- * Data types Mint (..), - mintRedeemerL, + TxSkelMints, + + -- * Optics + mintRedeemedScriptL, mintTokensL, - mint, - burn, - txSkelMintsValueG, + mintCurrencySymbolG, txSkelMintsListI, - mintVersionedScriptL, txSkelMintsAssetClassAmountL, + txSkelMintsAssetClassesG, + + -- * Smart constructors + mint, + burn, txSkelMintsFromList, - txSkelMintsValue, ) where import Cooked.Skeleton.Redeemer as X +import Cooked.Skeleton.User import Data.Bifunctor import Data.List.NonEmpty qualified as NEList import Data.Map (Map) @@ -26,9 +33,11 @@ import Data.Map qualified as Map import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEMap import Data.Maybe +import Data.String (IsString (fromString)) import Optics.Core import Optics.TH import Plutus.Script.Utils.Scripts qualified as Script +import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V1.Value qualified as Api import PlutusTx.AssocMap qualified as PMap import Test.QuickCheck (NonZero (..)) @@ -36,41 +45,48 @@ import Test.QuickCheck (NonZero (..)) -- * Describing single mint entries -- | A description of a new entry to be added in a 'TxSkelMints'. The users --- should be using lists of those (using 'txSkelMintsFromList') instead of +-- should be using lists of those (using @txSkelMintsFromList@) instead of -- building a 'TxSkelMints' directly. data Mint where Mint :: - (Script.ToVersioned Script.MintingPolicy a) => - { mintMintingPolicy :: a, - mintRedeemer :: TxSkelRedeemer, + { mintRedeemedScript :: User IsScript Redemption, mintTokens :: [(Api.TokenName, Integer)] } -> Mint -- * Extra builders for single mint entries +-- | Conveniency instance to be able to use Strings as 'Api.TokenName', which +-- used to be present in plutus-ledger-api. +instance IsString Api.TokenName where + fromString = Api.TokenName . fromString + -- | Builds some 'Mint' when a single type of token is minted for a given MP -mint :: (Script.ToVersioned Script.MintingPolicy a) => a -> TxSkelRedeemer -> Api.TokenName -> Integer -> Mint -mint mp red tn n = Mint mp red [(tn, n)] +mint :: (ToVScript a, RedeemerConstrs red) => a -> red -> Api.TokenName -> Integer -> Mint +mint mp red tn n = Mint (UserRedeemedScript (toVScript mp) (someTxSkelRedeemer red)) [(tn, n)] -- | Similar to 'mint' but deducing the tokens instead -burn :: (Script.ToVersioned Script.MintingPolicy a) => a -> TxSkelRedeemer -> Api.TokenName -> Integer -> Mint +burn :: (ToVScript a, RedeemerConstrs red) => a -> red -> Api.TokenName -> Integer -> Mint burn mp red tn n = mint mp red tn (-n) -- * Optics to manipulate elements of 'Mint' -- | A lens to set or get the redeemer of a 'Mint' -makeLensesFor [("mintRedeemer", "mintRedeemerL")] ''Mint +makeLensesFor [("mintRedeemedScript", "mintRedeemedScriptL")] ''Mint -- | A lens to set or get the token list of a 'Mint' makeLensesFor [("mintTokens", "mintTokensL")] ''Mint --- | A lens to set or get the versioned script of a 'Mint' -mintVersionedScriptL :: Lens' Mint (Script.Versioned Script.Script) -mintVersionedScriptL = - lens - (\(Mint mp _ _) -> Script.toScript <$> Script.toVersioned @Script.MintingPolicy mp) - (\m mp -> m {mintMintingPolicy = mp}) +-- | Returns the currency symbol associated with a `Mint` +mintCurrencySymbolG :: Getter Mint Api.CurrencySymbol +mintCurrencySymbolG = + mintRedeemedScriptL + % userVScriptL + % to + ( Script.toCurrencySymbol + . Script.toScriptHash + . toVScript + ) -- * Describing full minted values with associated redeemers @@ -78,11 +94,8 @@ mintVersionedScriptL = -- be one 'TxSkelRedeemer', and if there is, there must be some token names, each -- with a non-zero amount of tokens. -- --- You'll probably not construct this by hand, but use 'txSkelMintsFromList'. -type TxSkelMints = - Map - (Script.Versioned Script.MintingPolicy) - (TxSkelRedeemer, NEMap Api.TokenName (NonZero Integer)) +-- You'll probably not construct this by hand, but use 'review txSkelMintsListI'. +type TxSkelMints = Map VScript (TxSkelRedeemer, NEMap Api.TokenName (NonZero Integer)) -- * Optics to manipulate components of 'TxSkelMints' bind it to 'Mint' @@ -99,8 +112,8 @@ type TxSkelMints = -- for instance to modify an existing redeemer, or @ix mp % _2 % ix tk@ to -- modify a token amount. Another option is to use the optics working on 'Mint' -- and combining them with 'txSkelMintsListI'. -txSkelMintsAssetClassAmountL :: (Script.ToVersioned Script.MintingPolicy mp) => mp -> Api.TokenName -> Lens' TxSkelMints (Maybe TxSkelRedeemer, Integer) -txSkelMintsAssetClassAmountL (Script.toVersioned @Script.MintingPolicy -> mp) tk = +txSkelMintsAssetClassAmountL :: (ToVScript mp) => mp -> Api.TokenName -> Lens' TxSkelMints (Maybe TxSkelRedeemer, Integer) +txSkelMintsAssetClassAmountL (toVScript -> mp) tk = lens -- We return (Nothing, 0) when the mp is not in the map, (Just red, 0) when -- the mp is present but not the token, and (Just red, n) otherwise. @@ -124,25 +137,46 @@ txSkelMintsAssetClassAmountL (Script.toVersioned @Script.MintingPolicy -> mp) tk Just (prevRed, tokenMap) -> Map.insert mp (fromMaybe prevRed newRed, NEMap.insert tk (NonZero i) tokenMap) mints ) --- | The value described by a 'TxSkelMints' -txSkelMintsValueG :: Getter TxSkelMints Api.Value -txSkelMintsValueG = to txSkelMintsValue +instance Script.ToValue TxSkelMints where + toValue = + Api.Value + . PMap.unsafeFromList + . fmap + ( bimap + (Script.toCurrencySymbol . Script.toScriptHash) + ( PMap.unsafeFromList + . fmap (second getNonZero) + . NEList.toList + . NEMap.toList + . snd + ) + ) + . Map.toList + +-- | The list of assets classes contained in this 'TxSkelMints' +txSkelMintsAssetClassesG :: Getter TxSkelMints [(VScript, Api.TokenName)] +txSkelMintsAssetClassesG = txSkelMintsListI % to (\l -> [(toVScript mp, tk) | Mint (UserRedeemedScript mp _) tks <- l, (tk, _) <- tks]) -- | Seeing a 'TxSkelMints' as a list of 'Mint' txSkelMintsListI :: Iso' TxSkelMints [Mint] txSkelMintsListI = iso - (map (\(p, (r, m)) -> Mint p r $ second getNonZero <$> NEList.toList (NEMap.toList m)) . Map.toList) + (map (\(p, (r, m)) -> Mint (UserRedeemedScript p r) $ second getNonZero <$> NEList.toList (NEMap.toList m)) . Map.toList) ( foldl - ( \mints (Mint mp red tks) -> + ( \mints (Mint (UserRedeemedScript mp red) tks) -> foldl (\mints' (tk, n) -> mints' & txSkelMintsAssetClassAmountL mp tk %~ (\(_, n') -> (Just red, n + n'))) mints tks ) - mempty + Map.empty ) +-- | Builds a 'TxSkelMints' from a list of 'Mint'. This is equivalent to calling +-- @review txSkelMintsListI@ +txSkelMintsFromList :: [Mint] -> TxSkelMints +txSkelMintsFromList = review txSkelMintsListI + -- * Additional instances an useful helpers -- | Combining 'TxSkelMints' in a sensible way. In particular, this means that @@ -158,29 +192,10 @@ txSkelMintsListI = -- In every case, if you add mints with a different redeemer for the same -- policy, the redeemer used in the right argument takes precedence. instance {-# OVERLAPPING #-} Semigroup TxSkelMints where - a <> b = review txSkelMintsListI $ view txSkelMintsListI a ++ view txSkelMintsListI b + txSkelM <> txSkelM' = + review txSkelMintsListI $ + view txSkelMintsListI txSkelM + <> view txSkelMintsListI txSkelM' instance {-# OVERLAPPING #-} Monoid TxSkelMints where mempty = Map.empty - --- | This builds a 'TxSkelMints' from a list of 'Mint', which should be the main --- way of declaring minted values in a 'Cooked.Skeleton.TxSkel'. -txSkelMintsFromList :: [Mint] -> TxSkelMints -txSkelMintsFromList = review txSkelMintsListI - --- | This retrieves the 'Api.Value' from a 'TxSkelMints' -txSkelMintsValue :: TxSkelMints -> Api.Value -txSkelMintsValue = - Api.Value - . PMap.unsafeFromList - . fmap - ( bimap - Script.toCurrencySymbol - ( PMap.unsafeFromList - . fmap (second getNonZero) - . NEList.toList - . NEMap.toList - . snd - ) - ) - . Map.toList diff --git a/src/Cooked/Skeleton/Option.hs b/src/Cooked/Skeleton/Option.hs index 81b7ca84..3b62fe69 100644 --- a/src/Cooked/Skeleton/Option.hs +++ b/src/Cooked/Skeleton/Option.hs @@ -2,13 +2,15 @@ -- 'Cooked.Skeleton.TxSkel'. These options mostly revolves around customizing -- the default behavior of cooked-validators's transaction generation mechanism. module Cooked.Skeleton.Option - ( BalanceOutputPolicy (..), + ( -- * Data types + BalanceOutputPolicy (..), FeePolicy (..), BalancingPolicy (..), BalancingUtxos (..), CollateralUtxos (..), - AnchorResolution (..), TxSkelOpts (..), + + -- * Optics txSkelOptModTxL, txSkelOptAutoSlotIncreaseL, txSkelOptBalancingPolicyL, @@ -17,7 +19,8 @@ module Cooked.Skeleton.Option txSkelOptBalancingUtxosL, txSkelOptModParamsL, txSkelOptCollateralUtxosL, - txSkelOptAnchorResolutionL, + + -- * Utilities txSkelOptAddModTx, txSkelOptAddModParams, ) @@ -26,10 +29,7 @@ where import Cardano.Api qualified as Cardano import Cardano.Node.Emulator qualified as Emulator import Cooked.Wallet -import Data.ByteString (ByteString) import Data.Default -import Data.Map (Map) -import Data.Map qualified as Map import Data.Set (Set) import Optics.Core import Optics.TH @@ -108,19 +108,6 @@ data CollateralUtxos instance Default CollateralUtxos where def = CollateralUtxosFromBalancingWallet --- | Describes how to resolve anchors in proposal procedures -data AnchorResolution - = -- | Provide a map between urls and page content as Bytestring - AnchorResolutionLocal (Map String ByteString) - | -- | Allow online fetch of pages from a given URL. Important note: using - -- this option is unsafe, as it requires a web connection and inherently - -- prevents guarantees of reproducibily. Use at your own discretion. - AnchorResolutionHttp - deriving (Eq, Show) - -instance Default AnchorResolution where - def = AnchorResolutionLocal Map.empty - -- | Set of options to modify the behavior of generating and validating some -- transaction. data TxSkelOpts = TxSkelOpts @@ -189,31 +176,26 @@ data TxSkelOpts = TxSkelOpts -- computed automatically from a given, or the balancing, wallet. -- -- Default is 'CollateralUtxosFromBalancingWallet' - txSkelOptCollateralUtxos :: CollateralUtxos, - -- | How to resolve anchor in proposal procedures - -- - -- Default is 'AnchorResolutionLocal Map.Empty' - txSkelOptAnchorResolution :: AnchorResolution + txSkelOptCollateralUtxos :: CollateralUtxos } -- | Comparing 'TxSkelOpts' is possible as long as we ignore modifications to the -- generated transaction and the parameters. instance Eq TxSkelOpts where - (TxSkelOpts slotIncrease _ balancingPol feePol balOutputPol balUtxos _ colUtxos anchorRes) - == (TxSkelOpts slotIncrease' _ balancingPol' feePol' balOutputPol' balUtxos' _ colUtxos' anchorRes') = + (TxSkelOpts slotIncrease _ balancingPol feePol balOutputPol balUtxos _ colUtxos) + == (TxSkelOpts slotIncrease' _ balancingPol' feePol' balOutputPol' balUtxos' _ colUtxos') = slotIncrease == slotIncrease' && balancingPol == balancingPol' && feePol == feePol' && balOutputPol == balOutputPol' && balUtxos == balUtxos' && colUtxos == colUtxos' - && anchorRes == anchorRes' -- | Showing 'TxSkelOpts' is possible as long as we ignore modifications to the -- generated transaction and the parameters. instance Show TxSkelOpts where - show (TxSkelOpts slotIncrease _ balancingPol feePol balOutputPol balUtxos _ colUtxos anchorRes) = - show [show slotIncrease, show balancingPol, show feePol, show balOutputPol, show balUtxos, show colUtxos, show anchorRes] + show (TxSkelOpts slotIncrease _ balancingPol feePol balOutputPol balUtxos _ colUtxos) = + show [show slotIncrease, show balancingPol, show feePol, show balOutputPol, show balUtxos, show colUtxos] -- | A lens to get or set the automatic slot increase option makeLensesFor [("txSkelOptAutoSlotIncrease", "txSkelOptAutoSlotIncreaseL")] ''TxSkelOpts @@ -252,8 +234,7 @@ instance Default TxSkelOpts where txSkelOptFeePolicy = def, txSkelOptBalancingUtxos = def, txSkelOptModParams = id, - txSkelOptCollateralUtxos = def, - txSkelOptAnchorResolution = def + txSkelOptCollateralUtxos = def } -- | Appends a transaction modification to the given 'TxSkelOpts' diff --git a/src/Cooked/Skeleton/Output.hs b/src/Cooked/Skeleton/Output.hs index 11a5d16b..22849978 100644 --- a/src/Cooked/Skeleton/Output.hs +++ b/src/Cooked/Skeleton/Output.hs @@ -1,34 +1,41 @@ --- | This module exposes outputs as they can be defined in a --- 'Cooked.Skeleton.TxSkel' with various utilities around them. +-- | This module exposes the outputs constructs used in a +-- 'Cooked.Skeleton.TxSkel' and their associated utilities. To build payments in +-- a skeleton, the usual way is to invoke @txSkelIns = [pk `receives` Value v, +-- script `receives` (InlineDatum dat <&&> ReferenceScript script)]@ module Cooked.Skeleton.Output - ( TxSkelOut (..), - receives, + ( -- * Type constraints + IsTxSkelOutAllowedOwner (..), + + -- * Data types + PayableKind (..), + Payable (..), + TxSkelOut (..), + + -- * Optics txSkelOutValueL, txSkelOutValueAutoAdjustL, txSkelOutDatumL, - txSkelOutReferenceScriptL, - txSkelOutStakingCredentialL, - txSkelOutValidatorAT, - IsTxSkelOutAllowedOwner (..), - OwnerConstrs, + txSkelOutMReferenceScriptL, + txSkelOutReferenceScriptAT, + txSkelOutMStakingCredentialL, + txSkelOutStakingCredentialAT, txSkelOutCredentialG, txSkelOutAddressG, - txSkelOutPKHashAT, - txSkelOutTypedOwnerAT, - txSkelOutValidatorHashAF, - valueAssetClassAmountL, - lovelaceIntegerI, - valueLovelaceL, - valueAssetClassAmountP, - valueLovelaceP, - ownerCredentialG, + txSkelOutReferenceScriptHashAF, + txSkelOutOwnerL, + + -- * Smart constructors + (<&&>), + receives, ) where import Cooked.Skeleton.Datum -import Cooked.Skeleton.Payable -import Cooked.Skeleton.ReferenceScript +import Cooked.Skeleton.Families +import Cooked.Skeleton.User +import Cooked.Skeleton.Value () import Cooked.Wallet +import Data.Kind import Data.Typeable import Optics.Core import Optics.TH (makeLensesFor) @@ -39,54 +46,14 @@ import Plutus.Script.Utils.V3.Typed qualified as Script import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api -import PlutusTx.AssocMap qualified as PMap --- * Requirements to be able to own a 'TxSkelOut' - --- | A 'TxSkelOut' can either be owned by a pubkeyhash or a versioned validator -class IsTxSkelOutAllowedOwner a where - toPKHOrValidator :: a -> Either Api.PubKeyHash (Script.Versioned Script.Validator) - -instance IsTxSkelOutAllowedOwner Api.PubKeyHash where - toPKHOrValidator = Left - -instance IsTxSkelOutAllowedOwner Wallet where - toPKHOrValidator = Left . Script.toPubKeyHash +-- * Definition of 'Cooked.Skeleton.TxSkel' outputs -instance IsTxSkelOutAllowedOwner (Script.Versioned Script.Validator) where - toPKHOrValidator = Right - -instance IsTxSkelOutAllowedOwner (Script.TypedValidator a) where - toPKHOrValidator = toPKHOrValidator . Script.toVersioned @Script.Validator - -instance IsTxSkelOutAllowedOwner (Script.Versioned Script.Script) where - toPKHOrValidator = toPKHOrValidator . fmap Script.Validator - -instance IsTxSkelOutAllowedOwner (Either Api.PubKeyHash (Script.Versioned Script.Validator)) where - toPKHOrValidator = id - -instance IsTxSkelOutAllowedOwner (Script.MultiPurposeScript a) where - toPKHOrValidator = toPKHOrValidator . Script.toVersioned @Script.Validator - --- | Retrieves the credential of a 'TxSkelOut' allowed owner -ownerCredentialG :: (IsTxSkelOutAllowedOwner owner) => Getter owner Api.Credential -ownerCredentialG = to $ either Api.PubKeyCredential (Api.ScriptCredential . Script.toScriptHash) . toPKHOrValidator - --- | Type constraints over the owner of a 'TxSkelOut' -type OwnerConstrs owner = - ( IsTxSkelOutAllowedOwner owner, - Typeable owner, - Show owner - ) - --- * Definition of 'Cooked.Skeleton.TxSkel' outputs with associated optics - --- | A rich output to be put into a 'Cooked.Skeleton.TxSkel' +-- | An output to be put into a 'Cooked.Skeleton.TxSkel' data TxSkelOut where TxSkelOut :: - (OwnerConstrs owner) => - { -- The target of this payment - txSkelOutOwner :: owner, + { -- The owner of this payment + txSkelOutOwner :: User IsEither Allocation, -- What staking credential should be attached to this payment txSkelOutStakingCredential :: Maybe Api.StakingCredential, -- What datum should be placed in this payment @@ -96,134 +63,144 @@ data TxSkelOut where -- Whether the paid value can be auto-adjusted for min ADA txSkelOutValueAutoAdjust :: Bool, -- What reference script should be attached to this payment - txSkelOutReferenceScript :: TxSkelOutReferenceScript + txSkelOutReferenceScript :: Maybe VScript } -> TxSkelOut + deriving (Eq, Ord, Show) + +-- * Optics focusing on the reference script of a 'TxSkelOut' + +-- | Focuses on the @Maybe VScript@ corresponding to the possible reference +-- script contained in this 'TxSkelOut' +makeLensesFor [("txSkelOutReferenceScript", "txSkelOutMReferenceScriptL")] ''TxSkelOut -deriving instance Show TxSkelOut +-- | Focuses on the reference script of this 'TxSkelOut' +txSkelOutReferenceScriptAT :: AffineTraversal' TxSkelOut VScript +txSkelOutReferenceScriptAT = txSkelOutMReferenceScriptL % _Just --- | A lens to get or set the 'Maybe Api.StakingCredential' from a 'TxSkelOut' -makeLensesFor [("txSkelOutStakingCredential", "txSkelOutStakingCredentialL")] ''TxSkelOut +-- | Returns the possible reference script has of this 'TxSkelOut' +txSkelOutReferenceScriptHashAF :: AffineFold TxSkelOut Api.ScriptHash +txSkelOutReferenceScriptHashAF = txSkelOutReferenceScriptAT % to Script.toScriptHash --- | A lens to get or set the 'TxSkelOutDatum' from a 'TxSkelOut' +-- * Optics focusing on the staking credential of a 'TxSkelOut' + +-- | Focuses on the @Maybe StakingCredential@ of this 'TxSkelOut' +makeLensesFor [("txSkelOutStakingCredential", "txSkelOutMStakingCredentialL")] ''TxSkelOut + +-- | Focuses on the staking credential of this 'TxSkelOut' +txSkelOutStakingCredentialAT :: AffineTraversal' TxSkelOut Api.StakingCredential +txSkelOutStakingCredentialAT = txSkelOutMStakingCredentialL % _Just + +-- | Optics focusing on the datum of a 'TxSkelOut' + +-- | Focuses on the 'TxSkelOutDatum' of this 'TxSkelOut' makeLensesFor [("txSkelOutDatum", "txSkelOutDatumL")] ''TxSkelOut --- | A lens to get or set the 'Api.Value' from a 'TxSkelOut' +-- * Optics focusing on the value of this 'TxSkelOut' + +-- | Focuses on the 'Api.Value' of this 'TxSkelOut' makeLensesFor [("txSkelOutValue", "txSkelOutValueL")] ''TxSkelOut --- | A lens to get or set if the value can be auto-adjusted if needed +-- | Focuses on whether the 'Api.Value' contained in this 'TxSkelOut' can be +-- adjusted to min ADA during transaction generation makeLensesFor [("txSkelOutValueAutoAdjust", "txSkelOutValueAutoAdjustL")] ''TxSkelOut --- | A lens to get or set the 'TxSkelOutReferenceScript' from a 'TxSkelOut' -makeLensesFor [("txSkelOutReferenceScript", "txSkelOutReferenceScriptL")] ''TxSkelOut +-- * Optics focusing on the owner of this 'TxSkelOut' + +-- | Focuses on the user of this 'TxSkelOut' +makeLensesFor [("txSkelOutOwner", "txSkelOutOwnerL")] ''TxSkelOut + +-- * Additional optics around a 'TxSkelOut' -- | Returns the credential of this 'TxSkelOut' txSkelOutCredentialG :: Getter TxSkelOut Api.Credential -txSkelOutCredentialG = to $ \(TxSkelOut {txSkelOutOwner}) -> view ownerCredentialG txSkelOutOwner - -instance Script.ToCredential TxSkelOut where - toCredential = view txSkelOutCredentialG +txSkelOutCredentialG = to $ \(TxSkelOut {txSkelOutOwner}) -> Script.toCredential txSkelOutOwner -- | Returns the address of this 'TxSkelOut' txSkelOutAddressG :: Getter TxSkelOut Api.Address txSkelOutAddressG = to $ \txSkelOut -> Api.Address (view txSkelOutCredentialG txSkelOut) - (view txSkelOutStakingCredentialL txSkelOut) + (view txSkelOutMStakingCredentialL txSkelOut) + +-- * Instances for 'TxSkelOut' + +instance Script.ToCredential TxSkelOut where + toCredential = view txSkelOutCredentialG instance Script.ToAddress TxSkelOut where toAddress = view txSkelOutAddressG --- | Attempts to retrieve or set a typed owner from this 'TxSkelOut' -txSkelOutTypedOwnerAT :: (OwnerConstrs a, OwnerConstrs b) => AffineTraversal TxSkelOut TxSkelOut a b -txSkelOutTypedOwnerAT = - atraversal - (\txSkelOut@(TxSkelOut {txSkelOutOwner}) -> maybe (Left txSkelOut) Right (cast txSkelOutOwner)) - (\txSkelOut newOwner -> txSkelOut {txSkelOutOwner = newOwner}) - -instance Eq TxSkelOut where - txSkelOut == txSkelOut' = - view txSkelOutAddressG txSkelOut == view txSkelOutAddressG txSkelOut' - && txSkelOutDatum txSkelOut == txSkelOutDatum txSkelOut' - && txSkelOutValue txSkelOut == txSkelOutValue txSkelOut' - && preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptHashAF) txSkelOut - == preview (txSkelOutReferenceScriptL % txSkelOutReferenceScriptHashAF) txSkelOut' - --- | Returns the optional private key owning a given 'TxSkelOut' -txSkelOutPKHashAT :: AffineTraversal' TxSkelOut Api.PubKeyHash -txSkelOutPKHashAT = - atraversal - (\txSkelOut@(TxSkelOut {txSkelOutOwner}) -> either Right (const (Left txSkelOut)) $ toPKHOrValidator txSkelOutOwner) - (\txSkelOut pkh -> txSkelOut {txSkelOutOwner = pkh}) - --- | Returns the optional validator owning a given 'TxSkelOut' -txSkelOutValidatorAT :: AffineTraversal' TxSkelOut (Script.Versioned Script.Validator) -txSkelOutValidatorAT = - atraversal - (\txSkelOut@(TxSkelOut {txSkelOutOwner}) -> either (const $ Left txSkelOut) Right $ toPKHOrValidator txSkelOutOwner) - (\txSkelOut val -> txSkelOut {txSkelOutOwner = val}) - --- | Returns the optional validator hash owning a given 'TxSkelOut' -txSkelOutValidatorHashAF :: AffineFold TxSkelOut Script.ValidatorHash -txSkelOutValidatorHashAF = txSkelOutValidatorAT % to Script.toValidatorHash - --- * Additional optics revolving around 'Api.Value' - --- | A lens to get or set the amount of tokens of a certain 'Api.AssetClass' --- from a given 'Api.Value'. This removes the entry if the new amount is 0. -valueAssetClassAmountL :: (Script.ToMintingPolicyHash mp) => mp -> Api.TokenName -> Lens' Api.Value Integer -valueAssetClassAmountL (Script.toCurrencySymbol -> cs) tk = - lens - (`Api.assetClassValueOf` Api.assetClass cs tk) - ( \v@(Api.Value val) i -> case PMap.lookup cs val of - -- No previous cs entry and nothing to add. - Nothing | i == 0 -> v - -- No previous cs entry, and something to add. - Nothing -> Api.Value $ PMap.insert cs (PMap.singleton tk i) val - -- A previous cs and tk entry, which needs to be removed and the whole - -- cs entry as well because it only containes this tk. - Just (PMap.toList -> [(tk', _)]) | i == 0, tk == tk' -> Api.Value $ PMap.delete cs val - -- A previous cs and tk entry, which needs to be removed, but the whole - -- cs entry has other tokens and thus is kept. - Just tokenMap | i == 0 -> Api.Value $ PMap.insert cs (PMap.delete tk tokenMap) val - -- A previous cs entry, in which we insert the new tk (regarless of - -- whether the tk was already present). - Just tokenMap -> Api.Value $ PMap.insert cs (PMap.insert tk i tokenMap) val - ) - --- | Isomorphism between 'Api.Lovelace' and integers -lovelaceIntegerI :: Iso' Api.Lovelace Integer -lovelaceIntegerI = iso Api.getLovelace Api.Lovelace - --- | Focus the Lovelace part in a value. -valueLovelaceL :: Lens' Api.Value Api.Lovelace -valueLovelaceL = valueAssetClassAmountL Api.adaSymbol Api.adaToken % re lovelaceIntegerI - --- | A prism to build a value from an asset class and amount, or retrieves the --- amount from this asset class if it is not zero -valueAssetClassAmountP :: (Script.ToMintingPolicyHash mp) => mp -> Api.TokenName -> Prism' Api.Value Integer -valueAssetClassAmountP (Script.toCurrencySymbol -> cs) tk - | ac <- Api.assetClass cs tk = - prism - ( \case - i | i == 0 -> mempty - i -> Api.assetClassValue ac i - ) - ( \val -> case val `Api.assetClassValueOf` ac of - i | i == 0 -> Left val - i -> Right i - ) - --- | An instance of 'valueAssetClassAmountP' for 'Api.Lovelace' -valueLovelaceP :: Prism' Api.Value Api.Lovelace -valueLovelaceP = valueAssetClassAmountP Api.adaSymbol Api.adaToken % re lovelaceIntegerI +-- * Smart constructing the owner of a 'TxSkelOut' + +-- | A conveniency typeclass to automated the creation of 'TxSkelOut' owners, to +-- be used alongside 'Payable' with the smart constructor 'receives'. +class IsTxSkelOutAllowedOwner a where + toPKHOrVScript :: a -> User IsEither Allocation + +instance IsTxSkelOutAllowedOwner Api.PubKeyHash where + toPKHOrVScript = UserPubKey + +instance IsTxSkelOutAllowedOwner Wallet where + toPKHOrVScript = UserPubKey + +instance IsTxSkelOutAllowedOwner VScript where + toPKHOrVScript = UserScript + +instance (Typeable a) => IsTxSkelOutAllowedOwner (Script.TypedValidator a) where + toPKHOrVScript = UserScript + +instance IsTxSkelOutAllowedOwner (Script.Versioned Script.Validator) where + toPKHOrVScript = UserScript + +instance (Typeable a) => IsTxSkelOutAllowedOwner (Script.MultiPurposeScript a) where + toPKHOrVScript = UserScript + +instance IsTxSkelOutAllowedOwner (User IsEither Allocation) where + toPKHOrVScript = id + +-- * Smart constructing the payload of a 'TxSkelOut' + +-- | The kind of possible components of a 'TxSkelOut', other than the owner +data PayableKind where + IsDatum :: PayableKind + IsReferenceScript :: PayableKind + IsValue :: PayableKind + IsStakingCredential :: PayableKind + +-- | Payable elements. Created from concrete elements or composed. Notice that +-- there is no way of building an element of Type @Payable '[]@ so when using an +-- element of Type @Payable els@ we are sure that something was in fact +-- paid. Also, there is no way of building an element of type @Payable '[a,a]@ +-- so we also know at most one occurrence of each type of payment is performed. +data Payable :: [PayableKind] -> Type where + -- | Hashed datums visible in the transaction are payable + VisibleHashedDatum :: (DatumConstrs a) => a -> Payable '[IsDatum] + -- | Inline datums are payable + InlineDatum :: (DatumConstrs a) => a -> Payable '[IsDatum] + -- | Hashed datums hidden from the transaction are payable + HiddenHashedDatum :: (DatumConstrs a) => a -> Payable '[IsDatum] + -- | Reference scripts are payable + ReferenceScript :: (ToVScript s) => s -> Payable '[IsReferenceScript] + -- | Values are payable and are subject to min ada adjustment + Value :: (Script.ToValue a) => a -> Payable '[IsValue] + -- | Fixed Values are payable but are NOT subject to min ada adjustment + FixedValue :: (Script.ToValue a) => a -> Payable '[IsValue] + -- | Staking credentials are payable + StakingCredential :: (Script.ToMaybeStakingCredential cred) => cred -> Payable '[IsStakingCredential] + -- | Payables can be combined as long as their list of tags are disjoint + PayableAnd :: (els ⩀ els') => Payable els -> Payable els' -> Payable (els ∪ els') + +-- | An infix-usable alias for 'PayableAnd' +(<&&>) :: (els ⩀ els') => Payable els -> Payable els' -> Payable (els ∪ els') +(<&&>) = PayableAnd -- * Smart constructor to build 'TxSkelOut's --- | Smart constructor to build a 'TxSkelOut' from an owner and payment. This +-- | Smart constructor to build a 'TxSkelOut' from an @owner@ and 'Payable'. This -- should be the main way of building outputs. -receives :: (OwnerConstrs owner) => owner -> Payable els -> TxSkelOut -receives owner = +receives :: (IsTxSkelOutAllowedOwner owner) => owner -> Payable els -> TxSkelOut +receives (toPKHOrVScript -> owner) = ( `go` TxSkelOut owner @@ -231,21 +208,21 @@ receives owner = defaultTxSkelDatum -- Default datum defined below mempty -- Empty value by default True -- the value is adjustable to min ADA by default - NoTxSkelOutReferenceScript -- No reference script by default + Nothing -- No reference script by default) ) where go :: Payable els -> TxSkelOut -> TxSkelOut go (VisibleHashedDatum dat) = set txSkelOutDatumL (SomeTxSkelOutDatum dat (Hashed Resolved)) go (InlineDatum dat) = set txSkelOutDatumL (SomeTxSkelOutDatum dat Inline) go (HiddenHashedDatum dat) = set txSkelOutDatumL (SomeTxSkelOutDatum dat (Hashed NotResolved)) - go (FixedValue v) = set txSkelOutValueL (Script.toValue v) . set txSkelOutValueAutoAdjustL False - go (Value v) = set txSkelOutValueL (Script.toValue v) . set txSkelOutValueAutoAdjustL True - go (ReferenceScript script) = set txSkelOutReferenceScriptL (SomeTxSkelOutReferenceScript script) - go (StakingCredential stCred) = set txSkelOutStakingCredentialL (Script.toMaybeStakingCredential stCred) + go (FixedValue (Script.toValue -> v)) = set txSkelOutValueL v . set txSkelOutValueAutoAdjustL False + go (Value (Script.toValue -> v)) = set txSkelOutValueL v . set txSkelOutValueAutoAdjustL True + go (ReferenceScript (toVScript -> vScript)) = set txSkelOutMReferenceScriptL (Just vScript) + go (StakingCredential (Script.toMaybeStakingCredential -> mStCred)) = set txSkelOutMStakingCredentialL mStCred go (PayableAnd p1 p2) = go p2 . go p1 - defaultTxSkelDatum = case toPKHOrValidator owner of + defaultTxSkelDatum = case owner of -- V1 and V2 script always need a datum, even if empty - Right (Script.Versioned _ v) | v <= Script.PlutusV2 -> SomeTxSkelOutDatum () (Hashed NotResolved) + UserScript (toVScript -> Script.Versioned _ v) | v <= Script.PlutusV2 -> SomeTxSkelOutDatum () (Hashed NotResolved) -- V3 script and PKH do not necessarily need a datum _ -> NoTxSkelOutDatum diff --git a/src/Cooked/Skeleton/Payable.hs b/src/Cooked/Skeleton/Payable.hs deleted file mode 100644 index e48ff2f3..00000000 --- a/src/Cooked/Skeleton/Payable.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | This module defines the notion of 'Payable' elements with consist of the --- user API to build payments in a 'Cooked.Skeleton.TxSkel' -module Cooked.Skeleton.Payable - ( Payable (..), - type (∉), - type (⩀), - type (∪), - (<&&>), - ) -where - -import Cooked.Skeleton.Datum -import Cooked.Skeleton.ReferenceScript -import Data.Kind (Constraint, Type) -import GHC.TypeLits -import Plutus.Script.Utils.Address qualified as Script -import Plutus.Script.Utils.Value qualified as Script - --- | Constraint that a given type does not appear in a list of types -type family (∉) (el :: a) (els :: [a]) :: Constraint where - x ∉ '[] = () - x ∉ (x ': xs) = TypeError ('Text "Cannot have two payable elements of type: " ':<>: 'ShowType x) - x ∉ (_ ': xs) = x ∉ xs - --- | Disjoint lists of types -type family (⩀) (els :: [a]) (els' :: [a]) :: Constraint where - '[] ⩀ _ = () - (x ': xs) ⩀ ys = (x ∉ ys, xs ⩀ ys) - --- | Union with duplicates, which will not occur by construction in the --- concrete implentation of 'Payable' due to the '⩀' constraint. -type family (∪) (xs :: [a]) (ys :: [a]) :: [a] where - '[] ∪ ys = ys - (x ': xs) ∪ ys = x ': (xs ∪ ys) - --- | Payable elements. Created from concrete elements or composed. Notice that --- there is no way of building an element of Type @Payable '[]@ so when using an --- element of Type @Payable els@ we are sure that something was in fact paid. -data Payable :: [Symbol] -> Type where - -- | Hashed datums visible in the transaction are payable - VisibleHashedDatum :: (DatumConstrs a) => a -> Payable '["Datum"] - -- | Inline datums are payable - InlineDatum :: (DatumConstrs a) => a -> Payable '["Datum"] - -- | Hashed datums hidden from the transaction are payable - HiddenHashedDatum :: (DatumConstrs a) => a -> Payable '["Datum"] - -- | Reference scripts are payable - ReferenceScript :: (ReferenceScriptConstrs s) => s -> Payable '["Reference Script"] - -- | Values are payable and are subject to min ada adjustment - Value :: (Script.ToValue a) => a -> Payable '["Value"] - -- | Fixed Values are payable but are NOT subject to min ada adjustment - FixedValue :: (Script.ToValue a) => a -> Payable '["Value"] - -- | Staking credentials are payable - StakingCredential :: (Script.ToMaybeStakingCredential cred) => cred -> Payable '["Staking Credential"] - -- | Payables can be combined as long as their list of tags are disjoint - PayableAnd :: (els ⩀ els') => Payable els -> Payable els' -> Payable (els ∪ els') - --- | An infix-usable alias for 'PayableAnd' -(<&&>) :: (els ⩀ els') => Payable els -> Payable els' -> Payable (els ∪ els') -(<&&>) = PayableAnd diff --git a/src/Cooked/Skeleton/Proposal.hs b/src/Cooked/Skeleton/Proposal.hs index 187f63b3..d45e84d3 100644 --- a/src/Cooked/Skeleton/Proposal.hs +++ b/src/Cooked/Skeleton/Proposal.hs @@ -1,96 +1,107 @@ --- | This module exposes the notion of proposal within a --- 'Cooked.Skeleton.TxSkel' +-- | This module exposes the proposals constructs used in a +-- 'Cooked.Skeleton.TxSkel' and their associated utilities. To issue proposals +-- in a skeleton, the usual way is to invoke @txSkelProposals = [simpleProposal +-- script govAction1, simpleProposal pk govAction2, ... ]@ module Cooked.Skeleton.Proposal - ( TxParameterChange (..), - TxGovAction (..), + ( -- * Data types + ParameterChange (..), + GovernanceAction (..), TxSkelProposal (..), - txSkelProposalAddressL, - txSkelProposalActionL, - txSkelProposalWitnessL, + + -- * Optics txSkelProposalAnchorL, - txSkelProposalAutoConstitutionL, - simpleTxSkelProposal, - withWitness, - withAnchor, - withConstitution, - updateConstitution, + txSkelProposalMConstitutionAT, + txSkelProposalReturnCredentialL, + txSkelProposalGovernanceActionAT, + txSkelProposalConstitutionAT, + + -- * Smart constructors + simpleProposal, + + -- * Utilities + autoFillConstitution, ) where -import Cooked.Skeleton.Redeemer as X +import Cooked.Skeleton.Anchor +import Cooked.Skeleton.Redeemer +import Cooked.Skeleton.User +import Data.Kind (Type) import Data.Map (Map) -import Optics.Core ((&), (.~), (?~), (^.)) +import Data.Typeable +import Optics.Core import Optics.TH import Plutus.Script.Utils.Address qualified as Script -import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api import PlutusTx.Prelude qualified as PlutusTx +-- * Proposals for 'Cooked.Skeleton.TxSkel' + -- | These are all the protocol parameters. They are taken from -- https://github.com/IntersectMBO/cardano-ledger/blob/c4fbc05999866fea7c0cb1b211fd5288f286b95d/eras/conway/impl/cddl-files/conway.cddl#L381-L412 -- and will most likely change in future eras. -data TxParameterChange where +data ParameterChange where -- | The linear factor for the minimum fee calculation - FeePerByte :: Integer -> TxParameterChange + FeePerByte :: Integer -> ParameterChange -- | The constant factor for the minimum fee calculation - FeeFixed :: Integer -> TxParameterChange + FeeFixed :: Integer -> ParameterChange -- | Maximal block body size - MaxBlockBodySize :: Integer -> TxParameterChange + MaxBlockBodySize :: Integer -> ParameterChange -- | Maximal transaction size - MaxTxSize :: Integer -> TxParameterChange + MaxTxSize :: Integer -> ParameterChange -- | Maximal block header size - MaxBlockHeaderSize :: Integer -> TxParameterChange + MaxBlockHeaderSize :: Integer -> ParameterChange -- | The amount of a key registration deposit - KeyDeposit :: Integer -> TxParameterChange + KeyDeposit :: Integer -> ParameterChange -- | The amount of a pool registration deposit - PoolDeposit :: Integer -> TxParameterChange + PoolDeposit :: Integer -> ParameterChange -- | Maximum number of epochs in the future a pool retirement is allowed to -- be scheduled future for. - PoolRetirementMaxEpoch :: Integer -> TxParameterChange + PoolRetirementMaxEpoch :: Integer -> ParameterChange -- | Desired number of pools - PoolNumber :: Integer -> TxParameterChange + PoolNumber :: Integer -> ParameterChange -- | Pool influence - PoolInfluence :: Rational -> TxParameterChange + PoolInfluence :: Rational -> ParameterChange -- | Monetary expansion - MonetaryExpansion :: Rational -> TxParameterChange + MonetaryExpansion :: Rational -> ParameterChange -- | Treasury expansion - TreasuryCut :: Rational -> TxParameterChange + TreasuryCut :: Rational -> ParameterChange -- | Minimum Stake Pool Cost - MinPoolCost :: Integer -> TxParameterChange + MinPoolCost :: Integer -> ParameterChange -- | Cost in lovelace per byte of UTxO storage - CoinsPerUTxOByte :: Integer -> TxParameterChange + CoinsPerUTxOByte :: Integer -> ParameterChange -- | Cost models for non-native script languages CostModels :: { cmPlutusV1Costs :: [Integer], cmPlutusV2Costs :: [Integer], cmPlutusV3Costs :: [Integer] } -> - TxParameterChange + ParameterChange -- | Prices of execution units Prices :: { pMemoryCost :: Rational, pStepCost :: Rational } -> - TxParameterChange + ParameterChange -- | Max total script execution resources units allowed per tx MaxTxExUnits :: { mteuMemory :: Integer, mteuSteps :: Integer } -> - TxParameterChange + ParameterChange -- | Max total script execution resources units allowed per block MaxBlockExUnits :: { mbeuMemory :: Integer, mbeuSteps :: Integer } -> - TxParameterChange + ParameterChange -- | Max size of a Value in an output - MaxValSize :: Integer -> TxParameterChange + MaxValSize :: Integer -> ParameterChange -- | Percentage of the txfee which must be provided as collateral when -- including non-native scripts. - CollateralPercentage :: Integer -> TxParameterChange + CollateralPercentage :: Integer -> ParameterChange -- | Maximum number of collateral inputs allowed in a transaction - MaxCollateralInputs :: Integer -> TxParameterChange + MaxCollateralInputs :: Integer -> ParameterChange -- | Thresholds for pool votes PoolVotingThresholds :: { pvtMotionNoConfidence :: Rational, @@ -99,7 +110,7 @@ data TxParameterChange where pvtHardFork :: Rational, pvtSecurityGroup :: Rational } -> - TxParameterChange + ParameterChange -- | Thresholds for DRep votes DRepVotingThresholds :: { drvtMotionNoConfidence :: Rational, @@ -113,95 +124,110 @@ data TxParameterChange where drvtGovernanceGroup :: Rational, drvtTreasuryWithdrawal :: Rational } -> - TxParameterChange + ParameterChange -- | Minimum size of the Constitutional Committee - CommitteeMinSize :: Integer -> TxParameterChange + CommitteeMinSize :: Integer -> ParameterChange -- | The Constitutional Committee Term limit in number of Slots - CommitteeMaxTermLength :: Integer -> TxParameterChange + CommitteeMaxTermLength :: Integer -> ParameterChange -- | Gov action lifetime in number of Epochs - GovActionLifetime :: Integer -> TxParameterChange + GovActionLifetime :: Integer -> ParameterChange -- | The amount of the Gov Action deposit - GovActionDeposit :: Integer -> TxParameterChange + GovActionDeposit :: Integer -> ParameterChange -- | The amount of a DRep registration deposit - DRepRegistrationDeposit :: Integer -> TxParameterChange + DRepRegistrationDeposit :: Integer -> ParameterChange -- | The number of Epochs that a DRep can perform no activity without losing -- their @Active@ status. - DRepActivity :: Integer -> TxParameterChange - -- Reference scripts fee for the minimum fee calculation - MinFeeRefScriptCostPerByte :: Rational -> TxParameterChange + DRepActivity :: Integer -> ParameterChange + -- | Reference scripts fee for the minimum fee calculation + MinFeeRefScriptCostPerByte :: Rational -> ParameterChange deriving (Show, Eq) --- | This lists the various possible governance actions -data TxGovAction where +-- | This lists the various possible governance actions. Only two of these +-- action need to be witnessed by the constitution script, which we call +-- "witnessed gov actions" while the other do not need any witness, which we +-- call "simple gov actions". +data GovernanceAction :: UserKind -> Type where -- If several parameter changes are of the same kind, only the last -- one will take effect - TxGovActionParameterChange :: [TxParameterChange] -> TxGovAction - TxGovActionHardForkInitiation :: Api.ProtocolVersion -> TxGovAction - TxGovActionTreasuryWithdrawals :: Map Api.Credential Api.Lovelace -> TxGovAction - TxGovActionNoConfidence :: TxGovAction - TxGovActionUpdateCommittee :: [Api.ColdCommitteeCredential] -> Map Api.ColdCommitteeCredential Integer -> PlutusTx.Rational -> TxGovAction - TxGovActionNewConstitution :: Api.Constitution -> TxGovAction - deriving (Show, Eq) + ParameterChange :: [ParameterChange] -> GovernanceAction IsScript + TreasuryWithdrawals :: Map Api.Credential Api.Lovelace -> GovernanceAction IsScript + HardForkInitiation :: Api.ProtocolVersion -> GovernanceAction IsNone + NoConfidence :: GovernanceAction IsNone + UpdateCommittee :: [Api.ColdCommitteeCredential] -> Map Api.ColdCommitteeCredential Integer -> PlutusTx.Rational -> GovernanceAction IsNone + NewConstitution :: Api.Constitution -> GovernanceAction IsNone + +deriving instance Show (GovernanceAction a) + +deriving instance Eq (GovernanceAction a) -- | This bundles a governance action into an actual proposal data TxSkelProposal where TxSkelProposal :: - { -- | Whatever credential will get back the deposit - txSkelProposalAddress :: Api.Address, - -- | The proposed action - txSkelProposalAction :: TxGovAction, - -- | An optional script (typically the constitution script) to witness the - -- proposal and validate it. Only parameter changes and treasury - -- withdrawals can be subject to such a validation and transactions will - -- not pass validation phase 1 if other actions are given a witness. - txSkelProposalWitness :: Maybe (Script.Versioned Script.Script, TxSkelRedeemer), + ( Typeable kind, + Script.ToCredential cred + ) => + { -- | The credential that should be used for a return account + txSkelProposalReturnCredential :: cred, + -- | The proposed action gov action, either witnessed or simple + txSkelProposalGovernanceAction :: GovernanceAction kind, + -- | The constitution witness of this proposal, when paired with a + -- witnessed governance action. Is the governance action is simple, + -- only 'Nothing' can be provided there. + txSkelProposalConstitution :: Maybe (User kind Redemption), -- | An optional anchor to be given as additional data. It should -- correspond to the URL of a web page - txSkelProposalAnchor :: Maybe String, - -- | A flag to turn on/off the auto assignement of the constitution script - txSkelProposalAutoConstitution :: Bool + txSkelProposalAnchor :: TxSkelAnchor } -> TxSkelProposal - deriving (Show, Eq) --- | A lens to get or set the address of a 'TxSkelProposal' -makeLensesFor [("txSkelProposalAddress", "txSkelProposalAddressL")] ''TxSkelProposal +instance Show TxSkelProposal where + show (TxSkelProposal (Script.toCredential -> cred) action constit anchor) = show [show cred, show action, show constit, show anchor] --- | A lens to get or set the governance action of a 'TxSkelProposal' -makeLensesFor [("txSkelProposalAction", "txSkelProposalActionL")] ''TxSkelProposal +instance Eq TxSkelProposal where + (TxSkelProposal (Script.toCredential -> cred) action constit anchor) == (TxSkelProposal (Script.toCredential -> cred') action' constit' anchor') = + cred == cred' && cast action == Just action' && cast constit == Just constit' && anchor == anchor' --- | A lens to get or set the witness of a 'TxSkelProposal' -makeLensesFor [("txSkelProposalWitness", "txSkelProposalWitnessL")] ''TxSkelProposal +-- * Optics on 'TxSkelProposal' + +-- | Focuses on the return credential from a 'TxSkelProposal' +txSkelProposalReturnCredentialL :: Lens' TxSkelProposal Api.Credential +txSkelProposalReturnCredentialL = + lens + (\(TxSkelProposal {txSkelProposalReturnCredential}) -> Script.toCredential txSkelProposalReturnCredential) + (\txSkelProposal cred -> txSkelProposal {txSkelProposalReturnCredential = cred}) + +-- | Focuses on the optional constitution of a 'TxSkelProposal' +txSkelProposalMConstitutionAT :: forall kind. (Typeable kind) => AffineTraversal' TxSkelProposal (Maybe (User kind Redemption)) +txSkelProposalMConstitutionAT = + atraversal + (\prop@(TxSkelProposal {txSkelProposalConstitution}) -> maybe (Left prop) Right $ cast txSkelProposalConstitution) + (\prop@(TxSkelProposal @kind' cred action _ anchor) constit' -> maybe prop (\Refl -> TxSkelProposal cred action constit' anchor) $ eqT @kind @kind') + +-- | Focuses on the constitution of a 'TxSkelProposal' +txSkelProposalConstitutionAT :: AffineTraversal' TxSkelProposal (User IsScript Redemption) +txSkelProposalConstitutionAT = txSkelProposalMConstitutionAT % _Just + +-- | Focuses on the governance action of a 'TxSkelProposal' +txSkelProposalGovernanceActionAT :: forall req. (Typeable req) => AffineTraversal' TxSkelProposal (GovernanceAction req) +txSkelProposalGovernanceActionAT = + atraversal + (\prop@(TxSkelProposal {txSkelProposalGovernanceAction}) -> maybe (Left prop) Right $ cast txSkelProposalGovernanceAction) + (\prop@(TxSkelProposal @req' cred _ constit anchor) newAction -> maybe prop (\Refl -> TxSkelProposal cred newAction constit anchor) $ eqT @req @req') -- | A lens to get or set the anchor of a 'TxSkelProposal' makeLensesFor [("txSkelProposalAnchor", "txSkelProposalAnchorL")] ''TxSkelProposal --- | A lens to get or set the anchor of a 'TxSkelProposal' -makeLensesFor [("txSkelProposalAutoConstitution", "txSkelProposalAutoConstitutionL")] ''TxSkelProposal - --- | Builds a 'TxSkelProposal' from an address and a 'TxGovAction' -simpleTxSkelProposal :: (Script.ToAddress a) => a -> TxGovAction -> TxSkelProposal -simpleTxSkelProposal a govAction = TxSkelProposal (Script.toAddress a) govAction Nothing Nothing True - --- | Assigns a witness to a 'TxSkelProposal'. Also turns off the auto --- constitution flag, so that this witness is not overridden. -withWitness :: (Script.ToVersioned Script.Script a) => TxSkelProposal -> (a, TxSkelRedeemer) -> TxSkelProposal -withWitness prop (s, red) = - prop - & txSkelProposalWitnessL - ?~ (Script.toVersioned s, red) - & txSkelProposalAutoConstitutionL - .~ False - --- | Assigns the constitution script with an empty redeemer -withConstitution :: (Script.ToVersioned Script.Script a) => TxSkelProposal -> Maybe a -> TxSkelProposal -withConstitution prop sM = prop & txSkelProposalWitnessL .~ ((,emptyTxSkelRedeemer) . Script.toVersioned <$> sM) - --- | Assigns an anchor to a 'TxSkelProposal' -withAnchor :: TxSkelProposal -> String -> TxSkelProposal -withAnchor prop url = prop & txSkelProposalAnchorL ?~ url - --- | Updates the constitution if 'txSkelProposalAutoConstitution' is 'True' -updateConstitution :: (Script.ToVersioned Script.Script a) => TxSkelProposal -> Maybe a -> TxSkelProposal -updateConstitution prop sM | prop ^. txSkelProposalAutoConstitutionL = prop `withConstitution` sM -updateConstitution prop _ = prop +-- * Smart constructors and updators + +-- | Builds a 'TxSkelProposal' from a credential and a gov action. Does not set +-- any constitution (when applicable) nor anchor. +simpleProposal :: (Script.ToCredential cred, Typeable kind) => cred -> GovernanceAction kind -> TxSkelProposal +simpleProposal cred action = TxSkelProposal cred action Nothing Nothing + +-- | Sets the constitution script with an empty redeemer when empty. This will +-- not tamper with an existing constitution script and redeemer. +autoFillConstitution :: (ToVScript script, Typeable script) => script -> TxSkelProposal -> TxSkelProposal +autoFillConstitution constitution = + over + (txSkelProposalMConstitutionAT @IsScript) + (maybe (Just $ UserRedeemedScript constitution emptyTxSkelRedeemer) Just) diff --git a/src/Cooked/Skeleton/Redeemer.hs b/src/Cooked/Skeleton/Redeemer.hs index c0f15504..805b8906 100644 --- a/src/Cooked/Skeleton/Redeemer.hs +++ b/src/Cooked/Skeleton/Redeemer.hs @@ -1,17 +1,27 @@ -- | This module exposes the notion of redeemers used whenever a script in -- invoked in a 'Cooked.Skeleton.TxSkel'. module Cooked.Skeleton.Redeemer - ( TxSkelRedeemer (..), + ( -- * Type constraints RedeemerConstrs, - withReferenceInput, - someTxSkelRedeemer, - emptyTxSkelRedeemer, - txSkelRedeemerReferenceInputL, + + -- * Data types + TxSkelRedeemer (..), + + -- * Optics + txSkelRedeemerMReferenceInputL, + txSkelRedeemerReferenceInputAT, txSkelRedeemerAutoFillL, txSkelRedeemerTypedAT, + txSkelRedeemerBuiltinDataL, + + -- * Smart constructors + someTxSkelRedeemer, someTxSkelRedeemerNoAutoFill, + emptyTxSkelRedeemer, emptyTxSkelRedeemerNoAutoFill, - txSkelRedeemerBuiltinDataL, + + -- * Utilities + autoFillReferenceInput, ) where @@ -58,22 +68,24 @@ deriving instance (Show TxSkelRedeemer) instance Eq TxSkelRedeemer where (TxSkelRedeemer red mRefIn af) == TxSkelRedeemer red' mRefIn' af' = - cast red PlutusTx.== Just red' PlutusTx.&& mRefIn PlutusTx.== mRefIn' PlutusTx.&& af PlutusTx.== af' + (Api.toBuiltinData red, mRefIn, af) == (Api.toBuiltinData red', mRefIn', af') + +instance Ord TxSkelRedeemer where + compare (TxSkelRedeemer red mRefIn af) (TxSkelRedeemer red' mRefIn' af') = + compare (Api.toBuiltinData red, mRefIn, af) (Api.toBuiltinData red', mRefIn', af') -- * Navigating within a 'TxSkelRedeemer' --- | Sets or gets the reference input from a redeemer -makeLensesFor [("txSkelRedeemerReferenceInput", "txSkelRedeemerReferenceInputL")] ''TxSkelRedeemer +-- | Focuses on the possible reference input from a redeemer +makeLensesFor [("txSkelRedeemerReferenceInput", "txSkelRedeemerMReferenceInputL")] ''TxSkelRedeemer + +-- | Focuses on the reference input form a redeemer +txSkelRedeemerReferenceInputAT :: AffineTraversal' TxSkelRedeemer Api.TxOutRef +txSkelRedeemerReferenceInputAT = txSkelRedeemerMReferenceInputL % _Just -- | Sets or gets the autofill property from a redeemer makeLensesFor [("txSkelRedeemerAutoFill", "txSkelRedeemerAutoFillL")] ''TxSkelRedeemer --- | Attaches a reference input to a given 'TxSkelRedeemer'. This should usually --- be of no use if option 'Cooked.Skeleton.Option.txOptAutoReferenceScripts' is --- turned on, which is the case by default. -withReferenceInput :: TxSkelRedeemer -> Api.TxOutRef -> TxSkelRedeemer -withReferenceInput red ref = red & txSkelRedeemerReferenceInputL ?~ ref - -- | Extracts, or sets, the typed redeemer of a 'TxSkelRedeemer'. This is -- attempted in two ways: first, we try to simply cast the content, and then, if -- it fails, we serialise the content and then attempt to deserialise it to the @@ -116,3 +128,11 @@ emptyTxSkelRedeemer = someTxSkelRedeemer () -- while dissallowing it to be automatically assinged emptyTxSkelRedeemerNoAutoFill :: TxSkelRedeemer emptyTxSkelRedeemerNoAutoFill = someTxSkelRedeemerNoAutoFill () + +-- * Additional helpers + +-- | Attaches a reference input to this 'TxSkelRedeemer' when none is already +-- attached. Is meant to be used by the automated attachment process during +-- transaction generation. +autoFillReferenceInput :: Api.TxOutRef -> TxSkelRedeemer -> TxSkelRedeemer +autoFillReferenceInput refInput = over txSkelRedeemerMReferenceInputL (maybe (Just refInput) Just) diff --git a/src/Cooked/Skeleton/ReferenceScript.hs b/src/Cooked/Skeleton/ReferenceScript.hs deleted file mode 100644 index eb4f2c81..00000000 --- a/src/Cooked/Skeleton/ReferenceScript.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | This module exposes the notion of reference scripts used in our --- 'Cooked.Skeleton.TxSkel' -module Cooked.Skeleton.ReferenceScript - ( ReferenceScriptConstrs, - TxSkelOutReferenceScript (..), - txSkelOutReferenceScriptHashAF, - txSkelOutReferenceScriptTypedP, - txSkelOutReferenceScriptVersionedP, - ) -where - -import Data.Function (on) -import Data.Typeable -import Optics.Core -import Plutus.Script.Utils.Scripts qualified as Script -import PlutusLedgerApi.V3 qualified as Api - --- | Reference scripts are typeable and can be converted to versioned scripts. -type ReferenceScriptConstrs refScript = - ( Script.ToVersioned Script.Script refScript, - Typeable refScript - ) - --- | Reference scripts used in 'Cooked.Skeleton.Ouput.TxSkelOut' -data TxSkelOutReferenceScript where - NoTxSkelOutReferenceScript :: TxSkelOutReferenceScript - SomeTxSkelOutReferenceScript :: (ReferenceScriptConstrs a) => a -> TxSkelOutReferenceScript - -instance Eq TxSkelOutReferenceScript where - (==) = (==) `on` preview txSkelOutReferenceScriptHashAF - -instance Show TxSkelOutReferenceScript where - show refScript = - maybe - "No reference script" - (("Reference script: " <>) . show) - $ preview txSkelOutReferenceScriptHashAF refScript - --- | A prism targeting a certain typed reference script within a 'TxSkelOutReferenceScript' -txSkelOutReferenceScriptTypedP :: (ReferenceScriptConstrs a, ReferenceScriptConstrs b) => Prism TxSkelOutReferenceScript TxSkelOutReferenceScript a b -txSkelOutReferenceScriptTypedP = - prism - SomeTxSkelOutReferenceScript - ( \refScript -> case refScript of - NoTxSkelOutReferenceScript -> Left refScript - SomeTxSkelOutReferenceScript script -> maybe (Left refScript) Right (cast script) - ) - --- | A prism targeting the versioned script within a 'TxSkelOutReferenceScript' -txSkelOutReferenceScriptVersionedP :: Prism' TxSkelOutReferenceScript (Script.Versioned Script.Script) -txSkelOutReferenceScriptVersionedP = - prism - SomeTxSkelOutReferenceScript - ( \refScript -> case refScript of - NoTxSkelOutReferenceScript -> Left refScript - SomeTxSkelOutReferenceScript script -> Right (Script.toVersioned script) - ) - --- | An affine fold producing an optional script hash from a 'TxSkelOutReferenceScript' -txSkelOutReferenceScriptHashAF :: AffineFold TxSkelOutReferenceScript Api.ScriptHash -txSkelOutReferenceScriptHashAF = txSkelOutReferenceScriptVersionedP % to Script.toScriptHash diff --git a/src/Cooked/Skeleton/User.hs b/src/Cooked/Skeleton/User.hs new file mode 100644 index 00000000..21ac1c93 --- /dev/null +++ b/src/Cooked/Skeleton/User.hs @@ -0,0 +1,255 @@ +-- | This module exposes the notion of user used everywhere in our +-- 'Cooked.Skeleton.TxSkel'. A user can either be a script or a pubkey, and +-- might be used in a redemption or an allocation setting. All of this is +-- grouped under a single data type. Typically, users should rarely be created +-- by hands, and instead, smart constructors adapted to the user's location in +-- the skeleton should be used. +module Cooked.Skeleton.User + ( -- * Aliases + VScript, + ToVScript, + toVScript, + + -- * Data types + UserMode (..), + UserKind (..), + User (..), + + -- * Optics + userCredentialG, + userTxSkelRedeemerAT, + userVScriptAT, + userScriptHashAF, + userPubKeyHashAT, + userPubKeyHashI, + userVScriptL, + userScriptHashG, + userTxSkelRedeemerL, + userEitherScriptP, + userEitherPubKeyP, + userTypedAF, + userTypedScriptAT, + userTypedPubKeyAT, + ) +where + +import Cooked.Skeleton.Families +import Cooked.Skeleton.Redeemer +import Data.Kind +import Data.Typeable +import Optics.Core +import Plutus.Script.Utils.Address qualified as Script +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V3 qualified as Api + +-- * Handy aliases around versioned scripts + +-- | 'VScript' is a convenient alias as we have versioned scripts everywhere. +type VScript = Script.Versioned Script.Script + +-- | The 'ToVScript' alias will come in handy when dealing with constrains. +type ToVScript = Script.ToVersioned Script.Script + +-- | The 'toVScript' alias will come in handy to default the type parameter of +-- 'Script.toVersioned' to 'Script.Script'. +toVScript :: (ToVScript script) => script -> VScript +toVScript = Script.toVersioned + +-- * A depiction of user kinds and modes + +-- | The 'UserMode' corresponds to the way the user will be used in our +-- 'Cooked.Skeleton.TxSkel' which can either be for allocation (allocation a +-- certain entity to a user) or for redemption (using this user as a witness in +-- a transaction). +data UserMode = Allocation | Redemption + deriving (Eq, Show) + +-- | The 'UserKind' corresponds to the requirement on the type of users. Some +-- elements will require specifically a script and some others a pubkey. +data UserKind = IsScript | IsPubKey | IsEither | IsNone + deriving (Eq, Show) + +-- * Users, with their kind and mode + +-- | Building users. The type exposes the mode for which the user has been +-- built, and the requirements on the kind of the user. +data User :: UserKind -> UserMode -> Type where + -- | A pubkey user. This can be used whenever a pubkey is needed, and for + -- either of the possible modes. + UserPubKey :: forall pkh kind mode. (kind ∈ '[IsPubKey, IsEither], Script.ToPubKeyHash pkh, Typeable pkh) => pkh -> User kind mode + -- | A script user. This can be used whenever a script is needed, but only for + -- the allocation mode. + UserScript :: forall script kind. (kind ∈ '[IsScript, IsEither], ToVScript script, Typeable script) => script -> User kind Allocation + -- | A script user with an associated redeemer. This can be used whenever a + -- script is needed for redemption mode. + UserRedeemedScript :: forall script kind. (kind ∈ [IsScript, IsEither], ToVScript script, Typeable script) => script -> TxSkelRedeemer -> User kind Redemption + +instance Show (User kind mode) where + show (UserPubKey (Script.toPubKeyHash -> pkh)) = "UserPubKey " <> show pkh + show (UserScript (toVScript -> vScript)) = "UserScript " <> show (Script.toScriptHash vScript) + show (UserRedeemedScript (toVScript -> vScript) red) = "UserRedeemedScript " <> show (Script.toScriptHash vScript) <> " " <> show red + +instance Eq (User kind mode) where + (UserPubKey (Script.toPubKeyHash -> pkh)) == (UserPubKey (Script.toPubKeyHash -> pkh')) = + pkh == pkh' + (UserScript (Script.toScriptHash . toVScript -> sHash)) == (UserScript (Script.toScriptHash . toVScript -> sHash')) = + sHash == sHash' + (UserRedeemedScript (Script.toScriptHash . toVScript -> sHash) red) == (UserRedeemedScript (Script.toScriptHash . toVScript -> sHash') red') = + sHash == sHash' && red == red' + _ == _ = False + +instance Ord (User kind mode) where + compare (UserPubKey {}) (UserScript {}) = LT + compare (UserPubKey {}) (UserRedeemedScript {}) = LT + compare (UserScript {}) (UserPubKey {}) = GT + compare (UserRedeemedScript {}) (UserPubKey {}) = GT + compare (UserPubKey (Script.toPubKeyHash -> pkh)) (UserPubKey (Script.toPubKeyHash -> pkh')) = compare pkh pkh' + compare (UserScript (Script.toScriptHash . toVScript -> sh)) (UserScript (Script.toScriptHash . toVScript -> sh')) = compare sh sh' + compare (UserRedeemedScript (Script.toScriptHash . toVScript -> sh) red) (UserRedeemedScript (Script.toScriptHash . toVScript -> sh') red') = + compare (sh, red) (sh', red') + +instance Script.ToCredential (User kind mode) where + toCredential (UserPubKey (Script.toPubKeyHash -> pkh)) = Script.toCredential pkh + toCredential (UserScript (toVScript -> vScript)) = Script.toCredential vScript + toCredential (UserRedeemedScript (toVScript -> vScript) _) = Script.toCredential vScript + +-- * Optics on various possible families of users + +-- | Retrieves a possible typed user from a 'User' +userTypedAF :: forall user kind mode. (Typeable user) => AffineFold (User kind mode) user +userTypedAF = + afolding + ( \case + UserPubKey @user' pkh | Just Refl <- eqT @user @user' -> Just pkh + UserScript @user' script | Just Refl <- eqT @user @user' -> Just script + UserRedeemedScript @user' script _ | Just Refl <- eqT @user @user' -> Just script + _ -> Nothing + ) + +-- | Focuses on a possible typed script in this 'User' +userTypedScriptAT :: forall userScript mode. (ToVScript userScript, Typeable userScript) => AffineTraversal' (User IsScript mode) userScript +userTypedScriptAT = + atraversal + ( \user -> case user of + UserScript @userScript' script | Just Refl <- eqT @userScript @userScript' -> Right script + UserRedeemedScript @userScript' script _ | Just Refl <- eqT @userScript @userScript' -> Right script + _ -> Left user + ) + ( \case + UserScript _ -> UserScript + UserRedeemedScript _ red -> (`UserRedeemedScript` red) + ) + +-- | Focuses on a possible typed pubkey in this 'User' +userTypedPubKeyAT :: forall userPK mode. (Script.ToPubKeyHash userPK, Typeable userPK) => AffineTraversal' (User IsPubKey mode) userPK +userTypedPubKeyAT = + atraversal + ( \user -> case user of + UserPubKey @userPK' pkh | Just Refl <- eqT @userPK @userPK' -> Right pkh + _ -> Left user + ) + (\(UserPubKey _) -> UserPubKey) + +-- | Builds a @User IsEither@ from a @User IsScript@ +userEitherScriptP :: Prism' (User IsEither mode) (User IsScript mode) +userEitherScriptP = + prism + ( \case + UserScript script -> UserScript script + UserRedeemedScript script red -> UserRedeemedScript script red + ) + ( \case + UserScript script -> Right (UserScript script) + UserRedeemedScript script red -> Right (UserRedeemedScript script red) + user -> Left user + ) + +-- | Builds a @User IsEither@ from a @User IsPubKey@ +userEitherPubKeyP :: Prism' (User IsEither mode) (User IsPubKey mode) +userEitherPubKeyP = + prism + (\(UserPubKey pkh) -> UserPubKey pkh) + ( \case + UserPubKey pkh -> Right (UserPubKey pkh) + user -> Left user + ) + +-- | Extracts the 'Api.Credential' from a 'User' +userCredentialG :: Getter (User kind mode) Api.Credential +userCredentialG = to Script.toCredential + +-- | Focusing on the possible 'TxSkelRedeemer' of this 'User' +userTxSkelRedeemerAT :: AffineTraversal' (User kind mode) TxSkelRedeemer +userTxSkelRedeemerAT = + atraversal + ( \case + UserRedeemedScript _ red -> Right red + user -> Left user + ) + ( \case + UserRedeemedScript script _ -> UserRedeemedScript script + user -> const user + ) + +-- | Focusing on the possible 'VScript' of this 'User' +userVScriptAT :: AffineTraversal' (User kind mode) VScript +userVScriptAT = + atraversal + ( \case + UserScript (toVScript -> vScript) -> Right vScript + UserRedeemedScript (toVScript -> vScript) _ -> Right vScript + user -> Left user + ) + ( \case + UserScript _ -> UserScript + UserRedeemedScript _ red -> (`UserRedeemedScript` red) + user -> const user + ) + +-- | Focusing on the possible 'Api.ScriptHash' of this 'User' +userScriptHashAF :: AffineFold (User kind mode) Api.ScriptHash +userScriptHashAF = userVScriptAT % to Script.toScriptHash + +-- | Focusing on the possible 'Api.PubKeyHash' of this 'User' +userPubKeyHashAT :: AffineTraversal' (User kind mode) Api.PubKeyHash +userPubKeyHashAT = + atraversal + ( \case + UserPubKey (Script.toPubKeyHash -> pkh) -> Right pkh + user -> Left user + ) + ( \case + UserPubKey _ -> UserPubKey + user -> const user + ) + +-- | An isomorphism between users required to be pubkeys and 'Api.PubKeyHash' +userPubKeyHashI :: Iso' (User IsPubKey mode) Api.PubKeyHash +userPubKeyHashI = + iso + (\(UserPubKey (Script.toPubKeyHash -> pkh)) -> pkh) + UserPubKey + +-- | Focusing on the 'VScript' from a script +userVScriptL :: Lens' (User IsScript mode) VScript +userVScriptL = + lens + ( \case + UserScript (toVScript -> vScript) -> vScript + UserRedeemedScript (toVScript -> vScript) _ -> vScript + ) + ( \case + UserScript _ -> UserScript + UserRedeemedScript _ red -> (`UserRedeemedScript` red) + ) + +-- | Focusing on the 'Api.ScriptHash' from a script +userScriptHashG :: Getter (User IsScript mode) Api.ScriptHash +userScriptHashG = userVScriptL % to Script.toScriptHash + +-- | Focus on the 'TxSkelRedeemer' from a script being redeemed +userTxSkelRedeemerL :: Lens' (User IsScript Redemption) TxSkelRedeemer +userTxSkelRedeemerL = + lens + (\(UserRedeemedScript _ red) -> red) + (\(UserRedeemedScript script _) -> UserRedeemedScript script) diff --git a/src/Cooked/Skeleton/Value.hs b/src/Cooked/Skeleton/Value.hs new file mode 100644 index 00000000..e1b9be80 --- /dev/null +++ b/src/Cooked/Skeleton/Value.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This modules exposes optics around 'Api.Value' and 'Api.Lovelace' that we +-- use in our 'Cooked.Skeleton.TxSkel' and are not defined anywhere else. +module Cooked.Skeleton.Value + ( -- * Optics + valueAssetClassAmountL, + valueLovelaceL, + valueAssetClassAmountP, + valueLovelaceP, + lovelaceIntegerI, + ) +where + +import Optics.Core +import Plutus.Script.Utils.Scripts qualified as Script +import PlutusLedgerApi.V1.Value qualified as Api +import PlutusTx.AssocMap qualified as PMap + +-- | A lens to get or set the amount of tokens of a certain 'Api.AssetClass' +-- from a given 'Api.Value'. This removes the entry if the new amount is 0. +valueAssetClassAmountL :: (Script.ToMintingPolicyHash mp) => mp -> Api.TokenName -> Lens' Api.Value Integer +valueAssetClassAmountL (Script.toCurrencySymbol -> cs) tk = + lens + (`Api.assetClassValueOf` Api.assetClass cs tk) + ( \v@(Api.Value val) i -> case PMap.lookup cs val of + -- No previous cs entry and nothing to add. + Nothing | i == 0 -> v + -- No previous cs entry, and something to add. + Nothing -> Api.Value $ PMap.insert cs (PMap.singleton tk i) val + -- A previous cs and tk entry, which needs to be removed and the whole + -- cs entry as well because it only containes this tk. + Just (PMap.toList -> [(tk', _)]) | i == 0, tk == tk' -> Api.Value $ PMap.delete cs val + -- A previous cs and tk entry, which needs to be removed, but the whole + -- cs entry has other tokens and thus is kept. + Just tokenMap | i == 0 -> Api.Value $ PMap.insert cs (PMap.delete tk tokenMap) val + -- A previous cs entry, in which we insert the new tk (regarless of + -- whether the tk was already present). + Just tokenMap -> Api.Value $ PMap.insert cs (PMap.insert tk i tokenMap) val + ) + +-- | Isomorphism between 'Api.Lovelace' and integers +lovelaceIntegerI :: Iso' Api.Lovelace Integer +lovelaceIntegerI = iso Api.getLovelace Api.Lovelace + +-- | Focus the Lovelace part in a value. +valueLovelaceL :: Lens' Api.Value Api.Lovelace +valueLovelaceL = valueAssetClassAmountL Api.adaSymbol Api.adaToken % re lovelaceIntegerI + +-- | A prism to build a value from an asset class and amount, or retrieves the +-- amount from this asset class if it is not zero +valueAssetClassAmountP :: (Script.ToMintingPolicyHash mp) => mp -> Api.TokenName -> Prism' Api.Value Integer +valueAssetClassAmountP (Script.toCurrencySymbol -> cs) tk + | ac <- Api.assetClass cs tk = + prism + ( \case + i | i == 0 -> mempty + i -> Api.assetClassValue ac i + ) + ( \val -> case val `Api.assetClassValueOf` ac of + i | i == 0 -> Left val + i -> Right i + ) + +-- | An instance of 'valueAssetClassAmountP' for 'Api.Lovelace' +valueLovelaceP :: Prism' Api.Value Api.Lovelace +valueLovelaceP = valueAssetClassAmountP Api.adaSymbol Api.adaToken % re lovelaceIntegerI + +instance Ord Api.Value where + compare v1 v2 = compare (PMap.toList $ Api.getValue v1) (PMap.toList $ Api.getValue v2) diff --git a/src/Cooked/Skeleton/Withdrawal.hs b/src/Cooked/Skeleton/Withdrawal.hs index 38a84109..07ca91e5 100644 --- a/src/Cooked/Skeleton/Withdrawal.hs +++ b/src/Cooked/Skeleton/Withdrawal.hs @@ -1,31 +1,137 @@ --- | This module exposes the notion of Withdrawal within a --- 'Cooked.Skeleton.TxSkel' +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module exposes the withdrawing constructs used in a +-- 'Cooked.Skeleton.TxSkel' and their associated utilities. To issue withdrawals +-- in a skeleton, the usual way is to invoke @txSkelWithdrawals = +-- txSkelWithdrawalsFromList [pubKeyWithdrawal pk amount, scriptWithdrawal +-- script redeemer amount, ...]@ module Cooked.Skeleton.Withdrawal - ( TxSkelWithdrawals, - pkWithdrawal, + ( -- * Data types + Withdrawal (..), + TxSkelWithdrawals (..), + + -- * Optics + withdrawalUserL, + withdrawalAmountL, + txSkelWithdrawalsByPubKeysL, + txSkelWithdrawalsByScriptsL, + txSkelWithdrawalsByScriptL, + txSkelWithdrawalsByPubKeyL, + txSkelWithdrawalsListI, + + -- * Smart constructors + pubKeyWithdrawal, scriptWithdrawal, + txSkelWithdrawalsFromList, ) where import Cooked.Skeleton.Redeemer +import Cooked.Skeleton.User +import Data.Default import Data.Map (Map) import Data.Map qualified as Map +import Data.Typeable (Typeable, cast) +import Optics.Core +import Optics.TH import Plutus.Script.Utils.Address qualified as Script -import Plutus.Script.Utils.Scripts qualified as Script +import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api -- | Withdrawals associate either a script or a private key with a redeemer and --- a certain amount of ada. Note that the redeemer will be ignored in the case --- of a private key. -type TxSkelWithdrawals = - Map - (Either (Script.Versioned Script.Script) Api.PubKeyHash) - (TxSkelRedeemer, Api.Lovelace) - --- | Creates a 'TxSkelWithdrawals' from a private key hash and amount -pkWithdrawal :: (Script.ToPubKeyHash pkh) => pkh -> Integer -> TxSkelWithdrawals -pkWithdrawal pkh amount = Map.singleton (Right $ Script.toPubKeyHash pkh) (emptyTxSkelRedeemer, Api.Lovelace amount) - --- | Creates a 'TxSkelWithdrawals' from a script, redeemer and amount -scriptWithdrawal :: (Script.ToVersioned Script.Script script) => script -> TxSkelRedeemer -> Integer -> TxSkelWithdrawals -scriptWithdrawal script red amount = Map.singleton (Left $ Script.toVersioned script) (red, Api.Lovelace amount) +-- a certain amount of ada. +data TxSkelWithdrawals = TxSkelWithdrawals + { txSkelWithdrawalsByPubKeys :: Map Api.PubKeyHash Api.Lovelace, + txSkelWithdrawalsByScripts :: Map VScript (TxSkelRedeemer, Api.Lovelace) + } + deriving (Show, Eq) + +-- | Focuses on the pubkey withdrawals part of this 'TxSkelWithdrawals' +makeLensesFor [("txSkelWithdrawalsByPubKeys", "txSkelWithdrawalsByPubKeysL")] ''TxSkelWithdrawals + +-- | Focuses on the script withdrawals part of this 'TxSkelWithdrawals' +makeLensesFor [("txSkelWithdrawalsByScripts", "txSkelWithdrawalsByScriptsL")] ''TxSkelWithdrawals + +-- | Focuses on the deposit and redeemer for a given 'VScript' +txSkelWithdrawalsByScriptL :: (ToVScript script) => script -> Lens' TxSkelWithdrawals (Maybe (TxSkelRedeemer, Api.Lovelace)) +txSkelWithdrawalsByScriptL = (txSkelWithdrawalsByScriptsL %) . at . toVScript + +-- | Focuses on the deposit of a given 'Api.PubKeyHash' +txSkelWithdrawalsByPubKeyL :: (Script.ToPubKeyHash pkh) => pkh -> Lens' TxSkelWithdrawals (Maybe Api.Lovelace) +txSkelWithdrawalsByPubKeyL = (txSkelWithdrawalsByPubKeysL %) . at . Script.toPubKeyHash + +-- | A single 'Withdrawal', owned by a pubkey or redeemed script +data Withdrawal where + Withdrawal :: + { withdrawalUser :: User IsEither Redemption, + withdrawalAmount :: Api.Lovelace + } -> + Withdrawal + +deriving instance Show Withdrawal + +instance Eq Withdrawal where + Withdrawal user amount == Withdrawal user' amount' = cast user == Just user' && amount == amount' + +-- | Focuses on the amount in a 'Withdrawal' +makeLensesFor [("withdrawalAmount", "withdrawalAmountL")] ''Withdrawal + +-- | Focuses on the user owning a 'Withdrawal' +makeLensesFor [("withdrawalUser", "withdrawalUserL")] ''Withdrawal + +-- | Transforms a @[Withdrawal]@ to a 'TxSkelWithdrawals and vice +-- versa. Accumulates amount of withdrawals with similar owners, and keep the +-- latest found redeemer in the case of scripts, discarding the previous ones. +txSkelWithdrawalsListI :: Iso' TxSkelWithdrawals [Withdrawal] +txSkelWithdrawalsListI = + iso + ( \TxSkelWithdrawals {..} -> + fmap (\(pkh, amount) -> Withdrawal (UserPubKey pkh) amount) (Map.toList txSkelWithdrawalsByPubKeys) + ++ fmap (\(script, (red, amount)) -> Withdrawal (UserRedeemedScript script red) amount) (Map.toList txSkelWithdrawalsByScripts) + ) + ( foldl + ( \withdrawals (Withdrawal user amount) -> case user of + UserPubKey pkh -> + over + (txSkelWithdrawalsByPubKeyL pkh) + (maybe (Just amount) (Just . (amount +))) + withdrawals + UserRedeemedScript script red -> + over + (txSkelWithdrawalsByScriptL script) + (maybe (Just (red, amount)) (Just . (red,) . (amount +) . snd)) + withdrawals + ) + (TxSkelWithdrawals mempty mempty) + ) + +-- | Creates a 'Withdrawal' from a private key hash and lovelace amount +pubKeyWithdrawal :: (Script.ToPubKeyHash pkh, Typeable pkh) => pkh -> Integer -> Withdrawal +pubKeyWithdrawal pkh = Withdrawal (UserPubKey pkh) . Api.Lovelace + +-- | Creates a 'Withdrawal' from a redeemed script and lovelace amount +scriptWithdrawal :: (ToVScript script, Typeable script, RedeemerConstrs red) => script -> red -> Integer -> Withdrawal +scriptWithdrawal script red = Withdrawal (UserRedeemedScript script (someTxSkelRedeemer red)) . Api.Lovelace + +-- | Builds a 'TxSkelWithdrawals' from a list of 'Withdrawal'. This is +-- equivalent to calling @review txSkelWithdrawalsListI@ +txSkelWithdrawalsFromList :: [Withdrawal] -> TxSkelWithdrawals +txSkelWithdrawalsFromList = review txSkelWithdrawalsListI + +-- | Retrieves the total value withdrawn is this 'TxSkelWithdrawals' +instance Script.ToValue TxSkelWithdrawals where + toValue (TxSkelWithdrawals pkW scW) = + foldl (\val -> (val <>) . Script.toValue) mempty pkW + <> foldl (\val -> (val <>) . Script.toValue . snd) mempty scW + +instance Semigroup TxSkelWithdrawals where + txSkelW <> txSkelW' = + review txSkelWithdrawalsListI $ + view txSkelWithdrawalsListI txSkelW + <> view txSkelWithdrawalsListI txSkelW' + +instance Monoid TxSkelWithdrawals where + mempty = TxSkelWithdrawals mempty mempty + +instance Default TxSkelWithdrawals where + def = mempty diff --git a/tests/Spec.hs b/tests/Spec.hs index 34fa4c08..67081802 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,6 +1,7 @@ import Spec.Attack qualified as Attack import Spec.Balancing qualified as Balancing import Spec.BasicUsage qualified as BasicUsage +import Spec.Certificates qualified as Certificates import Spec.InitialDistribution qualified as InititalDistribution import Spec.InlineDatums qualified as InlineDatums import Spec.Ltl qualified as Ltl @@ -22,12 +23,13 @@ main = [ Attack.tests, Balancing.tests, BasicUsage.tests, + Certificates.tests, InititalDistribution.tests, InlineDatums.tests, Ltl.tests, MinAda.tests, MultiPurpose.tests, - ProposingScript.tests, + -- ProposingScript.tests, ReferenceInputs.tests, ReferenceScripts.tests, Slot.tests, diff --git a/tests/Spec/Attack/DatumHijacking.hs b/tests/Spec/Attack/DatumHijacking.hs index 1c8a2732..44246852 100644 --- a/tests/Spec/Attack/DatumHijacking.hs +++ b/tests/Spec/Attack/DatumHijacking.hs @@ -3,8 +3,8 @@ module Spec.Attack.DatumHijacking (tests) where import Cooked +import Data.Bifunctor import Data.Map qualified as Map -import Data.Set qualified as Set import Optics.Core import Plutus.Attack.DatumHijacking import Plutus.Script.Utils.V3 qualified as Script @@ -64,65 +64,63 @@ tests = testGroup "datum hijacking attack" [ testGroup "unit tests on a 'TxSkel'" $ - let val1 = carelessValidator - val2 = carefulValidator - x1 = Script.lovelace 10001 + let x1 = Script.lovelace 10001 x2 = Script.lovelace 10000 x3 = Script.lovelace 9999 skelIn = txSkelFromOuts - [ val1 `receives` (InlineDatum SecondLock <&&> Value x1), - val1 `receives` (InlineDatum SecondLock <&&> Value x3), - val2 `receives` (InlineDatum SecondLock <&&> Value x1), - val1 `receives` (InlineDatum FirstLock <&&> Value x2), - val1 `receives` (InlineDatum SecondLock <&&> Value x2) + [ carelessValidator `receives` (InlineDatum SecondLock <&&> Value x1), + carelessValidator `receives` (InlineDatum SecondLock <&&> Value x3), + carefulValidator `receives` (InlineDatum SecondLock <&&> Value x1), + carelessValidator `receives` (InlineDatum FirstLock <&&> Value x2), + carelessValidator `receives` (InlineDatum SecondLock <&&> Value x2) ] skelOut bound select = - runTweak - ( datumHijackingAttackAll @(Script.MultiPurposeScript DHContract) - ( \out@(TxSkelOut _ _ dat value _ _) -> - Just (Script.toValidatorHash val1) == preview txSkelOutValidatorHashAF out - && dat == SomeTxSkelOutDatum SecondLock Inline - && bound `Api.geq` value + ( fmap (second txSkelOuts) + <$> runTweak + ( datumHijackingAttack $ + ( txSkelOutPredDatumHijackingParams + ( \out -> + preview (txSkelOutOwnerL % userScriptHashAF) out == Just (Script.toScriptHash carelessValidator) + && view txSkelOutDatumL out == SomeTxSkelOutDatum SecondLock Inline + && bound `Api.geq` view txSkelOutValueL out + ) + thief + ) + { dhpAllOutputs = True, + dhpIndexPred = select + } ) - select - thief - ) - skelIn - skelExpected a b = - txSkelTemplate - { txSkelLabel = - Set.singleton . TxSkelLabel . DatumHijackingLbl $ Script.toCredential $ Script.toVersioned @Script.Script thief, - txSkelOuts = - [ val1 `receives` (InlineDatum SecondLock <&&> Value x1), - a `receives` (InlineDatum SecondLock <&&> Value x3), - val2 `receives` (InlineDatum SecondLock <&&> Value x1), - val1 `receives` (InlineDatum FirstLock <&&> Value x2), - b `receives` (InlineDatum SecondLock <&&> Value x2) - ], - txSkelSigners = [wallet 1] - } + skelIn + ) + outsExpected a b = + [ carelessValidator `receives` (InlineDatum SecondLock <&&> Value x1), + a `receives` (InlineDatum SecondLock <&&> Value x3), + carefulValidator `receives` (InlineDatum SecondLock <&&> Value x1), + carelessValidator `receives` (InlineDatum FirstLock <&&> Value x2), + b `receives` (InlineDatum SecondLock <&&> Value x2) + ] in [ testCase "no modified transactions if no interesting outputs to steal" $ [] @=? mcrValue <$> skelOut mempty (const True), testCase "one modified transaction for one interesting output" $ [ Right - ( [TxSkelOut val1 Nothing (SomeTxSkelOutDatum SecondLock Inline) x3 True NoTxSkelOutReferenceScript], - skelExpected thief val1 + ( [carelessValidator `receives` (InlineDatum SecondLock <&&> Value x3)], + outsExpected thief carelessValidator ) ] @=? mcrValue <$> skelOut x2 (0 ==), testCase "two modified transactions for two interesting outputs" $ [ Right - ( [ TxSkelOut val1 Nothing (SomeTxSkelOutDatum SecondLock Inline) x3 True NoTxSkelOutReferenceScript, - TxSkelOut val1 Nothing (SomeTxSkelOutDatum SecondLock Inline) x2 True NoTxSkelOutReferenceScript + ( [ carelessValidator `receives` (InlineDatum SecondLock <&&> Value x3), + carelessValidator `receives` (InlineDatum SecondLock <&&> Value x2) ], - skelExpected thief thief + outsExpected thief thief ) ] @=? mcrValue <$> skelOut x2 (const True), testCase "select second interesting output to get one modified transaction" $ [ Right - ( [TxSkelOut val1 Nothing (SomeTxSkelOutDatum SecondLock Inline) x2 True NoTxSkelOutReferenceScript], - skelExpected val1 thief + ( [carelessValidator `receives` (InlineDatum SecondLock <&&> Value x2)], + outsExpected carelessValidator thief ) ] @=? mcrValue <$> skelOut x2 (1 ==) @@ -130,26 +128,31 @@ tests = testCooked "careful validator" $ mustFailInPhase2Test $ somewhere - ( datumHijackingAttackAll @(Script.MultiPurposeScript DHContract) - ( \out@(TxSkelOut _ _ d _ _ _) -> - Just (Script.toValidatorHash carefulValidator) == preview txSkelOutValidatorHashAF out - && d == SomeTxSkelOutDatum SecondLock Inline + ( datumHijackingAttack $ + ( txSkelOutPredDatumHijackingParams + ( \out -> + preview (txSkelOutOwnerL % userScriptHashAF) out == Just (Script.toScriptHash carefulValidator) + && view txSkelOutDatumL out == SomeTxSkelOutDatum SecondLock Inline + ) + thief ) - (const True) - thief + { dhpAllOutputs = True + } ) (datumHijackingTrace carefulValidator), testCooked "careless validator" $ - mustSucceedTest - ( somewhere - ( datumHijackingAttackAll @(Script.MultiPurposeScript DHContract) - ( \out@(TxSkelOut _ _ d _ _ _) -> - Just (Script.toValidatorHash carelessValidator) == preview txSkelOutValidatorHashAF out - && d == SomeTxSkelOutDatum SecondLock Inline - ) - (const True) - thief - ) - (datumHijackingTrace carelessValidator) - ) + mustSucceedTest $ + somewhere + ( datumHijackingAttack $ + ( txSkelOutPredDatumHijackingParams + ( \out -> + preview (txSkelOutOwnerL % userScriptHashAF) out == Just (Script.toScriptHash carelessValidator) + && view txSkelOutDatumL out == SomeTxSkelOutDatum SecondLock Inline + ) + thief + ) + { dhpAllOutputs = True + } + ) + (datumHijackingTrace carelessValidator) ] diff --git a/tests/Spec/Attack/DupToken.hs b/tests/Spec/Attack/DupToken.hs index 1fb2e10a..0752b8df 100644 --- a/tests/Spec/Attack/DupToken.hs +++ b/tests/Spec/Attack/DupToken.hs @@ -1,7 +1,10 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + module Spec.Attack.DupToken (tests) where import Cooked import Data.Set qualified as Set +import Optics.Core import Plutus.Attack.DupToken import Plutus.Script.Utils.V3 qualified as Script import PlutusLedgerApi.V1.Value qualified as Api @@ -12,8 +15,8 @@ dupTokenTrace :: (MonadBlockChain m) => Script.Versioned Script.MintingPolicy -> dupTokenTrace pol tName amount recipient = validateTxSkel_ skel where skel = - let mints = txSkelMintsFromList [mint pol emptyTxSkelRedeemer tName amount] - mintedValue = txSkelMintsValue mints + let mints = review txSkelMintsListI [mint pol () tName amount] + mintedValue = Script.toValue mints in txSkelTemplate { txSkelMints = mints, txSkelOuts = [recipient `receives` Value mintedValue], @@ -35,9 +38,10 @@ tests = skelIn = txSkelTemplate { txSkelMints = - txSkelMintsFromList - [ mint pol1 emptyTxSkelRedeemer tName1 5, - mint pol2 emptyTxSkelRedeemer tName2 7 + review + txSkelMintsListI + [ mint pol1 () tName1 5, + mint pol2 () tName2 7 ], txSkelOuts = [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Script.lovelace 1234), @@ -53,9 +57,10 @@ tests = txSkelTemplate { txSkelLabel = Set.singleton $ TxSkelLabel DupTokenLbl, txSkelMints = - txSkelMintsFromList - [ mint pol1 emptyTxSkelRedeemer tName1 v1, - mint pol2 emptyTxSkelRedeemer tName2 v2 + review + txSkelMintsListI + [ mint pol1 () tName1 v1, + mint pol2 () tName2 v2 ], txSkelOuts = [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Script.lovelace 1234), @@ -67,23 +72,23 @@ tests = ) ] in [ testCase "add one token in every asset class" $ - skelExpected 6 8 @=? mcrValue <$> skelOut (\_ n -> n + 1), + skelExpected 6 8 @=? mcrValue <$> skelOut (\_ _ n -> n + 1), testCase "no modified transaction if no increase in value specified" $ - [] @=? mcrValue <$> skelOut (\_ n -> n), + [] @=? mcrValue <$> skelOut (\_ _ n -> n), testCase "add tokens depending on the asset class" $ - skelExpected 10 7 @=? mcrValue <$> skelOut (\ac n -> if ac == ac1 then n + 5 else n) + skelExpected 10 7 @=? mcrValue <$> skelOut (\mp tk n -> if Api.assetClass (Script.toCurrencySymbol mp) tk == ac1 then n + 5 else n) ], testCooked "careful minting policy" $ let tName = Api.TokenName "MockToken" pol = carefulPolicy tName 1 in mustFailInPhase2Test $ somewhere - (dupTokenAttack (\_ n -> n + 1) (wallet 6)) + (dupTokenAttack (\_ _ n -> n + 1) (wallet 6)) (dupTokenTrace pol tName 1 (wallet 1)), testCooked "careless minting policy" $ mustSucceedTest $ somewhere - (dupTokenAttack (\_ n -> n + 1) (wallet 6)) + (dupTokenAttack (\_ _ n -> n + 1) (wallet 6)) (dupTokenTrace carelessPolicy (Api.TokenName "MockToken") 1 (wallet 1)), testCase "pre-existing tokens are left alone" $ let attacker = wallet 6 @@ -93,7 +98,7 @@ tests = ac2 = Api.assetClass (Script.toCurrencySymbol Script.trueMintingMPScript) (Api.TokenName "preExistingToken") skelIn = txSkelTemplate - { txSkelMints = txSkelMintsFromList [mint pol emptyTxSkelRedeemer tName1 1], + { txSkelMints = review txSkelMintsListI [mint pol () tName1 1], txSkelOuts = [wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Api.assetClassValue ac2 2)], txSkelSigners = [wallet 2] } @@ -102,7 +107,7 @@ tests = ( Api.assetClassValue ac1 1, txSkelTemplate { txSkelLabel = Set.singleton $ TxSkelLabel DupTokenLbl, - txSkelMints = txSkelMintsFromList [mint pol emptyTxSkelRedeemer tName1 2], + txSkelMints = review txSkelMintsListI [mint pol () tName1 2], txSkelOuts = [ wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Api.assetClassValue ac2 2), attacker `receives` Value (Api.assetClassValue ac1 1) @@ -111,6 +116,6 @@ tests = } ) ] - skelOut = runTweak (dupTokenAttack (\_ i -> i + 1) attacker) skelIn + skelOut = runTweak (dupTokenAttack (\_ _ i -> i + 1) attacker) skelIn in skelExpected @=? mcrValue <$> skelOut ] diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index 2bdb7fab..db63001a 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -105,14 +105,14 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla aliceNonOnlyValueUtxos :: (MonadBlockChain m) => UtxoSearch m TxSkelOut aliceNonOnlyValueUtxos = utxosOwnedBySearch alice `filterWithPred` \o -> - is (txSkelOutReferenceScriptL % txSkelOutReferenceScriptVersionedP) o + is txSkelOutReferenceScriptAT o || is (txSkelOutDatumL % txSkelOutDatumKindAT) o aliceNAdaUtxos :: (MonadBlockChain m) => Integer -> UtxoSearch m TxSkelOut aliceNAdaUtxos n = utxosOwnedBySearch alice `filterWithValuePred` ((== Api.Lovelace (n * 1_000_000)) . Api.lovelaceValueOf) aliceRefScriptUtxos :: (MonadBlockChain m) => UtxoSearch m TxSkelOut -aliceRefScriptUtxos = utxosOwnedBySearch alice `filterWithPred` is (txSkelOutReferenceScriptL % txSkelOutReferenceScriptVersionedP) +aliceRefScriptUtxos = utxosOwnedBySearch alice `filterWithPred` is txSkelOutReferenceScriptAT emptySearch :: (MonadBlockChain m) => UtxoSearch m TxSkelOut emptySearch = ListT.fromFoldable [] diff --git a/tests/Spec/BasicUsage.hs b/tests/Spec/BasicUsage.hs index e2938bbb..3c2946c5 100644 --- a/tests/Spec/BasicUsage.hs +++ b/tests/Spec/BasicUsage.hs @@ -2,6 +2,7 @@ module Spec.BasicUsage where import Cooked import Data.Map qualified as Map +import Optics.Core import Plutus.Script.Utils.V3 qualified as Script import PlutusLedgerApi.V3 qualified as Api import Test.Tasty @@ -30,7 +31,7 @@ mintingQuickValue :: (MonadBlockChain m) => m () mintingQuickValue = validateTxSkel_ txSkelTemplate - { txSkelMints = txSkelMintsFromList [mint Script.trueMintingMPScript emptyTxSkelRedeemer (Api.TokenName "banana") 10], + { txSkelMints = review txSkelMintsListI [mint Script.trueMintingMPScript () (Api.TokenName "banana") 10], txSkelOuts = [alice `receives` Value (Script.multiPurposeScriptValue Script.trueMintingMPScript (Api.TokenName "banana") 10)], txSkelSigners = [alice] } diff --git a/tests/Spec/Certificates.hs b/tests/Spec/Certificates.hs new file mode 100644 index 00000000..2f654bf3 --- /dev/null +++ b/tests/Spec/Certificates.hs @@ -0,0 +1,137 @@ +module Spec.Certificates where + +import Cooked +import Data.Default +import Optics.Core +import Plutus.Script.Utils.V3 qualified as Script +import PlutusLedgerApi.V3 qualified as Api +import Test.Tasty + +alice :: Wallet +alice = wallet 1 + +bob :: Wallet +bob = wallet 1 + +publishCertificate :: (MonadModalBlockChain m) => TxSkelCertificate -> m () +publishCertificate cert = + validateTxSkel_ $ + txSkelTemplate + { txSkelSigners = [alice], + txSkelCertificates = [cert], + -- This fee is huge, we use it to force an output to be consumed when + -- the balancing equation is in favour of the output value. + txSkelOpts = def {txSkelOptFeePolicy = ManualFee 5_000_000} + } + +withdraw :: (MonadBlockChain m) => User IsEither Redemption -> m () +withdraw user = + validateTxSkel_ $ + txSkelTemplate + { txSkelSigners = [alice], + txSkelWithdrawals = review txSkelWithdrawalsListI [Withdrawal user 0], + txSkelOpts = def {txSkelOptFeePolicy = ManualFee 5_000_000} + } + +trueScriptUser :: User IsEither Redemption +trueScriptUser = UserRedeemedScript (toVScript $ Script.trueMPScript @()) emptyTxSkelRedeemer + +falseScriptUser :: User IsEither Redemption +falseScriptUser = UserRedeemedScript (toVScript $ Script.falseMPScript @()) emptyTxSkelRedeemer + +aliceUser :: User IsEither Redemption +aliceUser = UserPubKey $ Script.toPubKeyHash alice + +bobUser :: User IsEither Redemption +bobUser = UserPubKey $ Script.toPubKeyHash bob + +tests :: TestTree +tests = + testGroup + "Certificates" + [ testGroup + "Staking register certificates" + [ testCooked "Success when registering a wallet" $ + mustSucceedTest $ + publishCertificate $ + TxSkelCertificate aliceUser StakingRegister, + testCooked "Success when registering the true script" $ + mustSucceedTest $ + publishCertificate $ + TxSkelCertificate trueScriptUser StakingRegister, + testCooked "Failure when registering the false script" $ + mustFailInPhase2WithMsgTest "Unsupported purpose: Certifying" $ + publishCertificate $ + TxSkelCertificate falseScriptUser StakingRegister, + testCooked "Failure when withdrawing directly after registering" $ + mustFailTest $ do + publishCertificate $ TxSkelCertificate aliceUser StakingRegister + withdraw aliceUser + ], + testGroup + "Staking unregister certificates" + [ testCooked "Failure when unregistering a wallet not yet registered" $ + mustFailInPhase1Test $ + publishCertificate $ + TxSkelCertificate aliceUser StakingUnRegister, + testCooked "Success when unregistering a registered wallet" $ + mustSucceedTest $ do + publishCertificate $ TxSkelCertificate aliceUser StakingRegister + publishCertificate $ TxSkelCertificate aliceUser StakingUnRegister + ], + testGroup + "DRep registration certificates" + [ testCooked "We can register a wallet DRep" $ + mustSucceedTest $ + publishCertificate $ + TxSkelCertificate aliceUser DRepRegister, + testCooked "We cannot update a DRep not register" $ + mustFailInPhase1Test $ + publishCertificate $ + TxSkelCertificate aliceUser DRepUpdate, + testCooked "We can update a registered DRep" $ + mustSucceedTest $ do + publishCertificate $ TxSkelCertificate aliceUser DRepRegister + publishCertificate $ TxSkelCertificate aliceUser DRepUpdate, + testCooked "We cannot unregister an unregistered DRep" $ + mustFailInPhase1Test $ + publishCertificate $ + TxSkelCertificate aliceUser DRepUnRegister, + testCooked "We can unregister a registered DRep" $ + mustSucceedTest $ do + publishCertificate $ TxSkelCertificate aliceUser DRepRegister + publishCertificate $ TxSkelCertificate aliceUser DRepUnRegister, + testCooked "We can use a script as DRep..." $ + mustSucceedTest $ + publishCertificate $ + TxSkelCertificate trueScriptUser DRepRegister, + testCooked "... but the script might fail at registration" $ + mustFailInPhase2WithMsgTest "Unsupported purpose: Certifying" $ + publishCertificate $ + TxSkelCertificate falseScriptUser DRepRegister + ], + -- testGroup + -- "Pool registration certificates" + -- [ + -- testCooked "Success when registering a pool" $ + -- mustSucceedTest $ + -- publishCertificate $ + -- TxSkelCertificate aliceUser (PoolRegister undefined) + -- ], + testGroup + "Staking delegation certificates" + [ testCooked "Failure when delegating vote for a non registered credential" $ + mustFailInPhase1Test $ + publishCertificate $ + TxSkelCertificate aliceUser (StakingDelegate $ Api.DelegStake $ Script.toPubKeyHash bob), + testCooked "Success when delegating vote for a registered credential" $ + mustSucceedTest $ do + publishCertificate $ TxSkelCertificate aliceUser StakingRegister + publishCertificate $ TxSkelCertificate aliceUser (StakingDelegate $ Api.DelegVote Api.DRepAlwaysAbstain) + ] + ] + +-- gov action: 1 +-- d rep: 1 +-- pool: 0 +-- address: 2 diff --git a/tests/Spec/InitialDistribution.hs b/tests/Spec/InitialDistribution.hs index 0e1ada6d..06b5c086 100644 --- a/tests/Spec/InitialDistribution.hs +++ b/tests/Spec/InitialDistribution.hs @@ -42,7 +42,7 @@ spendReferenceAlwaysTrueValidator = do validateTxSkel_ $ txSkelTemplate { txSkelOuts = [alice `receives` Value (Script.ada 2)], - txSkelIns = Map.singleton scriptTxOutRef $ someTxSkelRedeemer () `withReferenceInput` referenceScriptTxOutRef, + txSkelIns = Map.singleton scriptTxOutRef $ TxSkelRedeemer () (Just referenceScriptTxOutRef) False, txSkelSigners = [bob] } diff --git a/tests/Spec/MultiPurpose.hs b/tests/Spec/MultiPurpose.hs index c7300d44..ca716cd0 100644 --- a/tests/Spec/MultiPurpose.hs +++ b/tests/Spec/MultiPurpose.hs @@ -3,8 +3,8 @@ module Spec.MultiPurpose where import Cooked -import Data.Default import Data.Map qualified as HMap +import Optics.Core import Plutus.MultiPurpose import Plutus.Script.Utils.V3 qualified as Script import PlutusLedgerApi.V1.Value qualified as Api @@ -57,7 +57,7 @@ runScript = do [ script `receives` (InlineDatum (0 :: Integer) <&&> Value mintValue2), script `receives` (InlineDatum (1 :: Integer) <&&> Value mintValue3) ], - txSkelMints = txSkelMintsFromList [burn script (someTxSkelRedeemer BurnToken) tn1 1] + txSkelMints = review txSkelMintsListI [burn script BurnToken tn1 1] } (oRefScript2'' : _) <- @@ -72,25 +72,25 @@ runScript = do txSkelOuts = [ script `receives` (InlineDatum (0 :: Integer) <&&> Value mintValue3) ], - txSkelMints = txSkelMintsFromList [burn script (someTxSkelRedeemer BurnToken) tn2 1] + txSkelMints = review txSkelMintsListI [burn script BurnToken tn2 1] } validateTxSkel_ $ txSkelTemplate { txSkelSigners = [alice], txSkelIns = HMap.singleton oRefScript2'' (someTxSkelRedeemer Close), - txSkelMints = txSkelMintsFromList [burn script (someTxSkelRedeemer BurnToken) tn3 1] + txSkelMints = review txSkelMintsListI [burn script BurnToken tn3 1] } where mkMintSkel :: Wallet -> Api.TxOutRef -> Script.MultiPurposeScript MPTag -> (TxSkel, Api.Value, Api.TokenName) - mkMintSkel signer oRef@(Api.TxOutRef _ ix) script = + mkMintSkel signer oRef@(Api.TxOutRef _ index) script = let tn = txOutRefToToken oRef - mints = txSkelMintsFromList [mint script (someTxSkelRedeemer (MintToken oRef)) tn 1] - mintValue = txSkelMintsValue mints + mints = review txSkelMintsListI [mint script (MintToken oRef) tn 1] + mintValue = Script.toValue mints in ( txSkelTemplate { txSkelIns = HMap.singleton oRef emptyTxSkelRedeemer, txSkelMints = mints, - txSkelOuts = [script `receives` (InlineDatum ix <&&> Value (txSkelMintsValue mints))], + txSkelOuts = [script `receives` (InlineDatum index <&&> Value mintValue)], txSkelSigners = [signer] }, mintValue, @@ -101,21 +101,21 @@ tests :: TestTree tests = testGroup "Multi purpose scripts" - [ testCooked "Using a script as minting and spending in the same scenario" $ mustSucceedTest runScript `withPrettyOpts` def {pcOptPrintTxOutRefs = PCOptTxOutRefsFull}, + [ testCooked "Using a script as minting and spending in the same scenario" $ mustSucceedTest runScript, testGroup "The Spending purpose behaves properly" [ testCooked "We cannot redirect any output to a private key" $ mustFailWithSizeTest 6 $ - somewhere (datumHijackingAttack @(Script.MultiPurposeScript MPTag) alice) runScript, + somewhere (datumHijackingAttack $ scriptsDatumHijackingParams alice) runScript, testCooked "We cannot redirect any output to another script" $ mustFailWithSizeTest 6 $ - somewhere (datumHijackingAttack @(Script.MultiPurposeScript MPTag) (Script.trueSpendingMPScript @())) runScript + somewhere (datumHijackingAttack $ scriptsDatumHijackingParams $ Script.trueSpendingMPScript @()) runScript ], testGroup "The Minting purpose behaves properly" [ testCooked "We cannot duplicate the tokens" $ mustFailWithSizeTest 6 $ - somewhere (dupTokenAttack (\_ n -> n + 1) alice) runScript, + somewhere (dupTokenAttack (\_ _ n -> n + 1) alice) runScript, testCooked "We cannot mint additional tokens" $ mustFailWithSizeTest 6 $ somewhere (addTokenAttack (const [(Api.TokenName "myToken", 1)]) alice) runScript diff --git a/tests/Spec/ProposingScript.hs b/tests/Spec/ProposingScript.hs index 5295131d..adc2c876 100644 --- a/tests/Spec/ProposingScript.hs +++ b/tests/Spec/ProposingScript.hs @@ -2,7 +2,6 @@ module Spec.ProposingScript where import Cooked import Plutus.ProposingScript -import Plutus.Script.Utils.V3 qualified as Script import Test.Tasty testProposingScript :: @@ -12,11 +11,11 @@ testProposingScript :: -- | Whether or not to automatically attach the constitution Bool -> -- | The official constitution script - Script.Versioned Script.Script -> + VScript -> -- | The optionally attached unofficial constitution script - Maybe (Script.Versioned Script.Script) -> + Maybe VScript -> -- | The governance action to propose - TxGovAction -> + GovernanceAction IsScript -> m () testProposingScript autoRefScript autoConstitution constitution mScript govAction = do setConstitutionScript constitution @@ -30,12 +29,24 @@ testProposingScript autoRefScript autoConstitution constitution mScript govActio { txSkelSigners = [wallet 1], txSkelProposals = [ TxSkelProposal - { txSkelProposalAddress = Script.toAddress (wallet 1), - txSkelProposalAction = govAction, - txSkelProposalAnchor = Nothing, - txSkelProposalWitness = (,if autoRefScript then emptyTxSkelRedeemer else emptyTxSkelRedeemerNoAutoFill) <$> mScript, - txSkelProposalAutoConstitution = autoConstitution - } + (wallet 1) + govAction + ( if autoConstitution + then + Nothing + else + ( \vScript -> + Just $ + UserRedeemedScript + vScript + ( if autoRefScript + then emptyTxSkelRedeemer + else emptyTxSkelRedeemerNoAutoFill + ) + ) + =<< mScript + ) + Nothing ] } @@ -47,33 +58,30 @@ tests = "No automated constitution attachment" [ testCooked "Failure when executing the wrong constitution script" $ mustFailInPhase1WithMsgTest "InvalidPolicyHash" $ - testProposingScript False False checkProposingScript (Just alwaysTrueProposingValidator) (TxGovActionParameterChange [FeePerByte 100]), + testProposingScript False False checkProposingScript (Just alwaysTrueProposingValidator) (ParameterChange [FeePerByte 100]), testCooked "Success when executing the right constitution script" $ mustSucceedTest $ - testProposingScript False False alwaysTrueProposingValidator (Just alwaysTrueProposingValidator) (TxGovActionParameterChange [FeePerByte 100]), + testProposingScript False False alwaysTrueProposingValidator (Just alwaysTrueProposingValidator) (ParameterChange [FeePerByte 100]), testCooked "Success when executing a more complex constitution script" $ mustSucceedTest $ - testProposingScript False False checkProposingScript (Just checkProposingScript) (TxGovActionParameterChange [FeePerByte 100]), + testProposingScript False False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 100]), testCooked "Failure when executing a more complex constitution script with the wrong proposal" $ mustFailInPhase2Test $ - testProposingScript False False checkProposingScript (Just checkProposingScript) (TxGovActionParameterChange [FeePerByte 50]), + testProposingScript False False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 50]), testCooked "Success when executing a more complex constitution script as a reference script" $ - mustSucceedTest (testProposingScript True False checkProposingScript (Just checkProposingScript) (TxGovActionParameterChange [FeePerByte 100])) - `withJournalProp` happened "MCLogAddedReferenceScript", - testCooked "Failure when executing a dummy proposal script with the wrong proposal kind" $ - mustFailInPhase2Test $ - testProposingScript False False alwaysTrueProposingValidator (Just alwaysTrueProposingValidator) TxGovActionNoConfidence + mustSucceedTest (testProposingScript True False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 100])) + `withJournalProp` happened "MCLogAddedReferenceScript" ], testGroup "Automated constitution attachment" [ testCooked "Success when auto assigning the constitution script" $ mustSucceedTest $ - testProposingScript False True checkProposingScript Nothing (TxGovActionParameterChange [FeePerByte 100]), + testProposingScript False True checkProposingScript Nothing (ParameterChange [FeePerByte 100]), testCooked "Success when auto assigning the constitution script and using it as a reference script" $ - mustSucceedTest (testProposingScript True True checkProposingScript Nothing (TxGovActionParameterChange [FeePerByte 100])) + mustSucceedTest (testProposingScript True True checkProposingScript Nothing (ParameterChange [FeePerByte 100])) `withJournalProp` happened "MCLogAddedReferenceScript", testCooked "Success when auto assigning the constitution script while overriding an existing one" $ mustSucceedTest $ - testProposingScript False True checkProposingScript (Just alwaysFalseProposingValidator) (TxGovActionParameterChange [FeePerByte 100]) + testProposingScript False True checkProposingScript (Just alwaysFalseProposingValidator) (ParameterChange [FeePerByte 100]) ] ] diff --git a/tests/Spec/ReferenceScripts.hs b/tests/Spec/ReferenceScripts.hs index c764db89..fc6d9e06 100644 --- a/tests/Spec/ReferenceScripts.hs +++ b/tests/Spec/ReferenceScripts.hs @@ -1,7 +1,6 @@ module Spec.ReferenceScripts where -import Cardano.Api.Internal.Tx.Body qualified as Cardano -import Cardano.Api.Internal.Tx.Sign qualified as Cardano +import Cardano.Api qualified as Cardano import Cooked import Data.Map qualified as Map import Data.Set qualified as Set @@ -40,9 +39,6 @@ putRefScriptOnScriptOutput recipient referenceScript = txSkelSigners = [wallet 1] } -retrieveRefScriptHash :: (MonadBlockChain m) => V3.TxOutRef -> m (Maybe Api.ScriptHash) -retrieveRefScriptHash = previewByRef (txSkelOutReferenceScriptL % txSkelOutReferenceScriptHashAF) - checkReferenceScriptOnOref :: (MonadBlockChain m) => Api.ScriptHash -> @@ -79,7 +75,7 @@ useReferenceScript spendingSubmitter consumeScriptOref theScript = do txSkelTemplate { txSkelIns = Map.fromList $ - (oref, emptyTxSkelRedeemer `withReferenceInput` scriptOref) + (oref, TxSkelRedeemer () (Just scriptOref) False) : [(scriptOref, emptyTxSkelRedeemer) | consumeScriptOref], txSkelSigners = spendingSubmitter : [wallet 3 | consumeScriptOref] } @@ -95,7 +91,7 @@ useReferenceScriptInInputs spendingSubmitter theScript = do } validateTxSkel_ txSkelTemplate - { txSkelIns = Map.fromList [(oref, emptyTxSkelRedeemer `withReferenceInput` scriptOref), (scriptOref, emptyTxSkelRedeemer)], + { txSkelIns = Map.fromList [(oref, TxSkelRedeemer () (Just scriptOref) False), (scriptOref, emptyTxSkelRedeemer)], txSkelSigners = [spendingSubmitter] } @@ -113,8 +109,10 @@ referenceMint mp1 mp2 n autoRefScript = do validateTxSkel_ $ txSkelTemplate { txSkelMints = - txSkelMintsFromList - [ mint mp2 (if autoRefScript then emptyTxSkelRedeemer else emptyTxSkelRedeemer `withReferenceInput` mpOutRef) (Api.TokenName "banana") 3 + review + txSkelMintsListI + [ set (mintRedeemedScriptL % userTxSkelRedeemerL) (if autoRefScript then emptyTxSkelRedeemer else TxSkelRedeemer () (Just mpOutRef) False) $ + mint mp2 () (Api.TokenName "banana") 3 ], txSkelOuts = [wallet 1 `receives` Value (Script.ada 2 <> Api.assetClassValue (Api.AssetClass (Script.toCurrencySymbol mp2, Api.TokenName "banana")) 3)], txSkelSigners = [wallet 1] @@ -129,11 +127,11 @@ tests = theRefScriptHash = Script.toScriptHash theRefScript in [ testCooked "on a public key output" $ mustSucceedTest - (putRefScriptOnWalletOutput (wallet 3) theRefScript >>= retrieveRefScriptHash) + (putRefScriptOnWalletOutput (wallet 3) theRefScript >>= previewByRef txSkelOutReferenceScriptHashAF) `withResultProp` (testCounterexample "the script hash on the retrieved output is wrong" . (Just theRefScriptHash .==.)), testCooked "on a script output" $ mustSucceedTest - (putRefScriptOnScriptOutput Script.alwaysSucceedValidatorVersioned theRefScript >>= retrieveRefScriptHash) + (putRefScriptOnScriptOutput Script.alwaysSucceedValidatorVersioned theRefScript >>= previewByRef txSkelOutReferenceScriptHashAF) `withResultProp` (testCounterexample "the script hash on the retrieved output is wrong" . (Just theRefScriptHash .==.)) ], testGroup @@ -165,7 +163,7 @@ tests = } validateTxSkel_ txSkelTemplate - { txSkelIns = Map.singleton oref (emptyTxSkelRedeemer `withReferenceInput` consumedOref), + { txSkelIns = Map.singleton oref (TxSkelRedeemer () (Just consumedOref) False), txSkelSigners = [wallet 1] } ) @@ -184,7 +182,7 @@ tests = } validateTxSkel_ txSkelTemplate - { txSkelIns = Map.singleton oref (emptyTxSkelRedeemer `withReferenceInput` scriptOref), + { txSkelIns = Map.singleton oref (TxSkelRedeemer () (Just scriptOref) False), txSkelSigners = [wallet 1] } ) diff --git a/tests/Spec/Withdrawals.hs b/tests/Spec/Withdrawals.hs index f44146b9..7a8a7db4 100644 --- a/tests/Spec/Withdrawals.hs +++ b/tests/Spec/Withdrawals.hs @@ -1,6 +1,7 @@ module Spec.Withdrawals where import Cooked +import Optics.Core import Plutus.Withdrawals import Test.Tasty @@ -10,11 +11,7 @@ testWithdrawingScript reward deposit inRedeemer actual = do validateTxSkel_ $ txSkelTemplate { txSkelSigners = [wallet 1], - txSkelWithdrawals = - scriptWithdrawal - checkWithdrawalMPScript - (someTxSkelRedeemer (inRedeemer * 1_000)) - (actual * 1_000) + txSkelWithdrawals = review txSkelWithdrawalsListI [scriptWithdrawal checkWithdrawalMPScript (inRedeemer * 1_000) (actual * 1_000)] } tests :: TestTree @@ -29,11 +26,15 @@ tests = testCooked "We cannot withdraw if we are not registered" $ mustFailInPhase1WithMsgTest "WithdrawalsNotInRewardsCERTS" $ testWithdrawingScript 2 2 2 2 - `withTweak` setTweak txSkelWithdrawalsL (scriptWithdrawal trueWithdrawalMPScript (someTxSkelRedeemer (2_000 :: Integer)) 2_000), - testCooked "A wallet can also make a withdrawal" $ - mustSucceedTest $ - testWithdrawingScript 2 2 2 2 - `withTweak` do - registerStakingCred (wallet 1) 2_000 0 - setTweak txSkelWithdrawalsL (pkWithdrawal (wallet 1) 2_000) + `withTweak` setTweak + (txSkelWithdrawalsL % txSkelWithdrawalsListI) + [scriptWithdrawal trueWithdrawalMPScript (2_000 :: Integer) 2_000] -- , + -- testCooked "A wallet can also make a withdrawal" $ + -- mustSucceedTest $ + -- testWithdrawingScript 2 2 2 2 + -- `withTweak` do + -- registerStakingCred (wallet 1) 2_000 0 + -- setTweak + -- (txSkelWithdrawalsL % txSkelWithdrawalsListI) + -- [pkWithdrawal (wallet 1) 2_000] ]