From b718bae909add1015d913d0ce122cdff9ef5b359 Mon Sep 17 00:00:00 2001 From: mmontin Date: Mon, 3 Aug 2026 01:14:47 +0200 Subject: [PATCH 01/18] Add SomeTxSkelOutDatumHash datum variant Introduce a `SomeTxSkelOutDatumHash` constructor for `TxSkelOutDatum` representing an output datum known only by its hash, and propagate it throughout the codebase: - Datum.hs: Eq/Ord, kind/typed optics, datum-hash fold and ToOutputDatum - GenerateTx/Output.hs: emit a TxOutDatumHash - GenerateTx/Input.hs: throw the new MCESpendingHashOnlyDatum error when a spending witness would require the (absent) datum content - State.hs: mirror it with a new UtxoPayloadDatumHash constructor - Pretty printers for the skeleton, UTxO state and the new error Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- CHANGELOG.md | 6 ++++++ .../MockChain/Automation/GenerateTx/Input.hs | 14 ++++++------- .../MockChain/Automation/GenerateTx/Output.hs | 3 +++ src/Cooked/MockChain/Runtime/Error.hs | 3 +++ src/Cooked/MockChain/Runtime/State.hs | 8 +++++++ src/Cooked/Pretty/MockChain.hs | 6 ++++++ src/Cooked/Pretty/Skeleton.hs | 2 ++ src/Cooked/Skeleton/Datum.hs | 21 ++++++++++++++++--- 8 files changed, 53 insertions(+), 10 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2dd415fa7..2417c7024 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,12 @@ ### Added +- New `SomeTxSkelOutDatumHash` constructor for `TxSkelOutDatum`, representing an + output datum known only by its hash (no datum content). It is mirrored by a + new `UtxoPayloadDatumHash` constructor in the resulting `UtxoState`, and a new + `MCESpendingHashOnlyDatum` error is raised when attempting to build the + spending witness of a script output whose datum is only a hash. + ### Changed ### Removed diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs b/src/Cooked/MockChain/Automation/GenerateTx/Input.hs index 7d2c6091e..7d8a8f2d6 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Input.hs @@ -25,11 +25,11 @@ toTxInAndWitness (txOutRef, txSkelRedeemer) = do TxSkelOut {txSkelOutOwner, txSkelOutDatum} <- txSkelOutByRef txOutRef witness <- case txSkelOutOwner of UserPubKey _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending - UserScript script -> - fmap (Cardano.ScriptWitness Cardano.ScriptWitnessForSpending) $ - toScriptWitness script txSkelRedeemer $ - case txSkelOutDatum of - NoTxSkelOutDatum -> Cardano.ScriptDatumForTxIn Nothing - SomeTxSkelOutDatum _ Inline -> Cardano.InlineScriptDatum - SomeTxSkelOutDatum dat _ -> Cardano.ScriptDatumForTxIn $ Just $ P.Ledger.toCardanoScriptData $ Api.toBuiltinData dat + UserScript script -> do + scriptDatum <- case txSkelOutDatum of + NoTxSkelOutDatum -> return $ Cardano.ScriptDatumForTxIn Nothing + SomeTxSkelOutDatum _ Inline -> return Cardano.InlineScriptDatum + SomeTxSkelOutDatum dat _ -> return $ Cardano.ScriptDatumForTxIn $ Just $ P.Ledger.toCardanoScriptData $ Api.toBuiltinData dat + SomeTxSkelOutDatumHash hash -> throw $ MCESpendingHashOnlyDatum txOutRef hash + Cardano.ScriptWitness Cardano.ScriptWitnessForSpending <$> toScriptWitness script txSkelRedeemer scriptDatum (,Cardano.BuildTxWith witness) <$> fromEither (P.Ledger.toCardanoTxIn txOutRef) diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs b/src/Cooked/MockChain/Automation/GenerateTx/Output.hs index 0b833e3d8..561d9b2b7 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Output.hs @@ -41,4 +41,7 @@ toCardanoTxOut output = do Cardano.TxOutDatumInline Cardano.BabbageEraOnwardsConway $ P.Ledger.toCardanoScriptData $ Api.toBuiltinData datum + SomeTxSkelOutDatumHash hash -> + Cardano.TxOutDatumHash Cardano.AlonzoEraOnwardsConway + <$> fromEither (P.Ledger.toCardanoScriptDataHash hash) return $ Cardano.TxOut address value datum $ P.Ledger.toCardanoReferenceScript oRefScript diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/MockChain/Runtime/Error.hs index d65ca9570..54b3a536c 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/MockChain/Runtime/Error.hs @@ -54,6 +54,9 @@ data MockChainError MCEPastSlot P.Ledger.Slot P.Ledger.Slot | -- | An attempt to invoke an unsupported feature has been made MCEUnsupportedFeature String + | -- | An attempt to spend a script output whose datum is only known by its + -- hash, which does not provide the datum content required by the witness + MCESpendingHashOnlyDatum Api.TxOutRef Api.DatumHash | -- | Used to provide 'MonadFail' instances. MCEFailure String deriving (Show, Eq) diff --git a/src/Cooked/MockChain/Runtime/State.hs b/src/Cooked/MockChain/Runtime/State.hs index 2c0f6afe7..9c64782e8 100644 --- a/src/Cooked/MockChain/Runtime/State.hs +++ b/src/Cooked/MockChain/Runtime/State.hs @@ -116,6 +116,7 @@ removeOutput oRef = set (mcstOutputsL % at oRef % _Just % _2) False data UtxoPayloadDatum where NoUtxoPayloadDatum :: UtxoPayloadDatum SomeUtxoPayloadDatum :: (DatumConstrs dat) => dat -> Bool -> UtxoPayloadDatum + UtxoPayloadDatumHash :: Api.DatumHash -> UtxoPayloadDatum -- | Focuses on the optional hashed flag of a 'UtxoPayloadDatum' utxoPayloadDatumKindAT :: AffineTraversal' UtxoPayloadDatum Bool @@ -124,11 +125,13 @@ utxoPayloadDatumKindAT = ( \case NoUtxoPayloadDatum -> Left NoUtxoPayloadDatum SomeUtxoPayloadDatum _ b -> Right b + UtxoPayloadDatumHash _ -> Right True ) ( flip ( \kind -> \case NoUtxoPayloadDatum -> NoUtxoPayloadDatum SomeUtxoPayloadDatum content _ -> SomeUtxoPayloadDatum content kind + datum@(UtxoPayloadDatumHash _) -> datum ) ) @@ -146,6 +149,7 @@ utxoPayloadDatumTypedAT = ( \content -> \case NoUtxoPayloadDatum -> NoUtxoPayloadDatum SomeUtxoPayloadDatum _ kind -> SomeUtxoPayloadDatum content kind + UtxoPayloadDatumHash _ -> SomeUtxoPayloadDatum content True ) ) @@ -159,6 +163,9 @@ instance Ord UtxoPayloadDatum where (SomeUtxoPayloadDatum (Api.toBuiltinData -> dat) b) (SomeUtxoPayloadDatum (Api.toBuiltinData -> dat') b') = compare (dat, b) (dat', b') + compare SomeUtxoPayloadDatum {} _ = LT + compare _ SomeUtxoPayloadDatum {} = GT + compare (UtxoPayloadDatumHash hash) (UtxoPayloadDatumHash hash') = compare hash hash' instance Eq UtxoPayloadDatum where dat == dat' = compare dat dat' == EQ @@ -269,6 +276,7 @@ mcstToUtxoState = ( case view txSkelOutDatumL txSkelOut of NoTxSkelOutDatum -> NoUtxoPayloadDatum SomeTxSkelOutDatum content kind -> SomeUtxoPayloadDatum content (kind /= Inline) + SomeTxSkelOutDatumHash hash -> UtxoPayloadDatumHash hash ) (preview txSkelOutReferenceScriptHashAF txSkelOut) ] diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index b3260106b..8b4655ff3 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -100,6 +100,11 @@ instance PrettyCooked MockChainError where <+> "but instead got:" <+> (case got of Nothing -> "none"; Just sHash -> prettyHash opts sHash) prettyCookedOpt _ (MCEUnsupportedFeature feature) = "Unsupported feature:" <+> PP.pretty feature + prettyCookedOpt opts (MCESpendingHashOnlyDatum txOutRef datumHash) = + "Unable to spend the following output, whose datum is only known by its hash:" + <+> prettyCookedOpt opts txOutRef + <+> "with datum hash:" + <+> prettyHash opts datumHash prettyCookedOpt _ (MCEPastSlot current target) = "Unable to move back in time; current slot:" <+> PP.viaShow current @@ -263,6 +268,7 @@ instance PrettyCookedList UtxoPayloadSet where splitDatum :: UtxoPayloadDatum -> Maybe (DocCooked, Bool) splitDatum NoUtxoPayloadDatum = Nothing splitDatum (SomeUtxoPayloadDatum dat b) = Just (prettyCookedOpt opts dat, b) + splitDatum (UtxoPayloadDatumHash hash) = Just (prettyHash opts hash, True) newtype CollateralInput = CollateralInput {unCollateralInput :: Api.TxOutRef} diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index 9cc812e9b..cbbe3e4b6 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/src/Cooked/Pretty/Skeleton.hs @@ -277,6 +277,8 @@ instance PrettyCookedMaybe TxSkelOutDatum where <> prettyHash opts (Api.toBuiltinData dat) <> "):" <+> PP.align (prettyCookedOpt opts dat) + prettyCookedOptMaybe opts (SomeTxSkelOutDatumHash hash) = + Just $ "Datum (hash only)" <+> "(" <> prettyHash opts hash <> ")" -- | Pretty-print a list of transaction skeleton options, only printing an -- option if its value is non-default. diff --git a/src/Cooked/Skeleton/Datum.hs b/src/Cooked/Skeleton/Datum.hs index f606fe384..f53d58fc3 100644 --- a/src/Cooked/Skeleton/Datum.hs +++ b/src/Cooked/Skeleton/Datum.hs @@ -75,16 +75,19 @@ datumKindResolvedP = -- | Datums to be placed in 'Cooked.Skeleton.TxSkel' outputs, which are either -- empty, or composed of a datum content and its placement data TxSkelOutDatum where - -- | use no datum + -- | Don't use any datum NoTxSkelOutDatum :: TxSkelOutDatum - -- | use some datum content and associated placement + -- | Use some datum content with a datum kind SomeTxSkelOutDatum :: (DatumConstrs dat) => dat -> DatumKind -> TxSkelOutDatum + -- | Use some datum hash only + SomeTxSkelOutDatumHash :: Api.DatumHash -> TxSkelOutDatum 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') + (SomeTxSkelOutDatumHash hash) == (SomeTxSkelOutDatumHash hash') = hash == hash' _ == _ = False instance Ord TxSkelOutDatum where @@ -95,6 +98,9 @@ instance Ord TxSkelOutDatum where (SomeTxSkelOutDatum (Api.toBuiltinData -> dat) b) (SomeTxSkelOutDatum (Api.toBuiltinData -> dat') b') = compare (dat, b) (dat', b') + compare SomeTxSkelOutDatum {} _ = LT + compare _ SomeTxSkelOutDatum {} = GT + compare (SomeTxSkelOutDatumHash hash) (SomeTxSkelOutDatumHash hash') = compare hash hash' -- * Optics working on 'TxSkelOutDatum' @@ -105,11 +111,13 @@ txSkelOutDatumKindAT = ( \case NoTxSkelOutDatum -> Left NoTxSkelOutDatum SomeTxSkelOutDatum _ kind -> Right kind + SomeTxSkelOutDatumHash _ -> Right (Hashed NotResolved) ) ( flip ( \kind -> \case NoTxSkelOutDatum -> NoTxSkelOutDatum SomeTxSkelOutDatum content _ -> SomeTxSkelOutDatum content kind + datum@(SomeTxSkelOutDatumHash _) -> datum ) ) @@ -135,6 +143,7 @@ txSkelOutDatumTypedAT = ( \content -> \case NoTxSkelOutDatum -> NoTxSkelOutDatum SomeTxSkelOutDatum _ kind -> SomeTxSkelOutDatum content kind + SomeTxSkelOutDatumHash _ -> SomeTxSkelOutDatum content (Hashed NotResolved) ) ) @@ -144,7 +153,12 @@ txSkelOutDatumDatumAF = txSkelOutDatumTypedAT % to Api.Datum -- | Retrieves the optional 'Api.DatumHash' of a 'TxSkelOutDatum' txSkelOutDatumDatumHashAF :: AffineFold TxSkelOutDatum Api.DatumHash -txSkelOutDatumDatumHashAF = txSkelOutDatumDatumAF % to Script.datumHash +txSkelOutDatumDatumHashAF = + afolding + ( \case + SomeTxSkelOutDatumHash hash -> Just hash + datum -> Script.datumHash <$> preview txSkelOutDatumDatumAF datum + ) -- | Retrieves the 'Api.OutputDatum' of a 'TxSkelOutDatum' txSkelOutDatumOutputDatumG :: Getter TxSkelOutDatum Api.OutputDatum @@ -154,3 +168,4 @@ instance Script.ToOutputDatum TxSkelOutDatum where toOutputDatum NoTxSkelOutDatum = Api.NoOutputDatum toOutputDatum (SomeTxSkelOutDatum datum Inline) = Api.OutputDatum $ Api.Datum $ Api.toBuiltinData datum toOutputDatum (SomeTxSkelOutDatum datum _) = Api.OutputDatumHash $ Script.datumHash $ Api.Datum $ Api.toBuiltinData datum + toOutputDatum (SomeTxSkelOutDatumHash hash) = Api.OutputDatumHash hash From aa1a54901584fc25954c6cc2a8477cf83de5ffbc Mon Sep 17 00:00:00 2001 From: mmontin Date: Mon, 3 Aug 2026 01:58:10 +0200 Subject: [PATCH 02/18] Add UserScriptHash owner for hash-only script allocation Introduce a `UserScriptHash Api.ScriptHash` constructor for `User`, allowing outputs to be paid to a bare script hash via `receives`. Since such an owner carries no script body or version, spending it recovers the full script from the redeemer's reference input and errors with the new `MCESpendingHashOnlyScript` otherwise. `userVScriptL` is narrowed to `User IsScript Redemption` accordingly. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- CHANGELOG.md | 8 ++++ .../MockChain/Automation/GenerateTx/Input.hs | 23 +++++++-- src/Cooked/MockChain/Runtime/Error.hs | 3 ++ src/Cooked/Pretty/MockChain.hs | 6 +++ src/Cooked/Pretty/Skeleton.hs | 1 + src/Cooked/Skeleton/Output.hs | 3 ++ src/Cooked/Skeleton/User.hs | 47 ++++++++++++++----- 7 files changed, 75 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2417c7024..9a3d57888 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,14 @@ ### Added +- New `UserScriptHash` constructor for `User`, representing an allocation-mode + script owner known only by its `Api.ScriptHash` (no script body). It can be + used to pay to a bare script hash through `receives` (a new + `IsTxSkelOutAllowedOwner Api.ScriptHash` instance). Spending an output owned by + such a user requires providing the full script through a matching reference + input; otherwise a new `MCESpendingHashOnlyScript` error is raised. The + `userVScriptL` optic is now restricted to `User IsScript Redemption`, since an + allocation-mode script owner may no longer carry a script body. - New `SomeTxSkelOutDatumHash` constructor for `TxSkelOutDatum`, representing an output datum known only by its hash (no datum content). It is mirrored by a new `UtxoPayloadDatumHash` constructor in the resulting `UtxoState`, and a new diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs b/src/Cooked/MockChain/Automation/GenerateTx/Input.hs index 7d8a8f2d6..082a1db33 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Input.hs @@ -7,6 +7,8 @@ import Cooked.MockChain.Effect.Read import Cooked.MockChain.Runtime.Error import Cooked.Skeleton import Ledger.Tx.CardanoAPI qualified as P.Ledger +import Optics.Core +import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api import Polysemy import Polysemy.Error @@ -23,13 +25,26 @@ toTxInAndWitness :: ) toTxInAndWitness (txOutRef, txSkelRedeemer) = do TxSkelOut {txSkelOutOwner, txSkelOutDatum} <- txSkelOutByRef txOutRef - witness <- case txSkelOutOwner of - UserPubKey _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending - UserScript script -> do - scriptDatum <- case txSkelOutDatum of + let toScriptDatum = case txSkelOutDatum of NoTxSkelOutDatum -> return $ Cardano.ScriptDatumForTxIn Nothing SomeTxSkelOutDatum _ Inline -> return Cardano.InlineScriptDatum SomeTxSkelOutDatum dat _ -> return $ Cardano.ScriptDatumForTxIn $ Just $ P.Ledger.toCardanoScriptData $ Api.toBuiltinData dat SomeTxSkelOutDatumHash hash -> throw $ MCESpendingHashOnlyDatum txOutRef hash + witness <- case txSkelOutOwner of + UserPubKey _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending + UserScript script -> do + scriptDatum <- toScriptDatum Cardano.ScriptWitness Cardano.ScriptWitnessForSpending <$> toScriptWitness script txSkelRedeemer scriptDatum + UserScriptHash sHash -> do + scriptDatum <- toScriptDatum + -- The full script is not available in the owner, so it must be recovered + -- from the reference script of the redeemer's reference input. + mVScript <- case txSkelRedeemerReferenceInput txSkelRedeemer of + Nothing -> return Nothing + Just refOutRef -> preview txSkelOutReferenceScriptAT <$> txSkelOutByRef refOutRef + case mVScript of + Just vScript + | Script.toScriptHash vScript == sHash -> + Cardano.ScriptWitness Cardano.ScriptWitnessForSpending <$> toScriptWitness vScript txSkelRedeemer scriptDatum + _ -> throw $ MCESpendingHashOnlyScript txOutRef sHash (,Cardano.BuildTxWith witness) <$> fromEither (P.Ledger.toCardanoTxIn txOutRef) diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/MockChain/Runtime/Error.hs index 54b3a536c..03f2119b8 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/MockChain/Runtime/Error.hs @@ -57,6 +57,9 @@ data MockChainError | -- | An attempt to spend a script output whose datum is only known by its -- hash, which does not provide the datum content required by the witness MCESpendingHashOnlyDatum Api.TxOutRef Api.DatumHash + | -- | An attempt to spend a script output whose script is only known by its + -- hash, without providing the full script through a matching reference input + MCESpendingHashOnlyScript Api.TxOutRef Api.ScriptHash | -- | Used to provide 'MonadFail' instances. MCEFailure String deriving (Show, Eq) diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index 8b4655ff3..7a946bd9b 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -105,6 +105,12 @@ instance PrettyCooked MockChainError where <+> prettyCookedOpt opts txOutRef <+> "with datum hash:" <+> prettyHash opts datumHash + prettyCookedOpt opts (MCESpendingHashOnlyScript txOutRef scriptHash) = + "Unable to spend the following output, whose script is only known by its hash:" + <+> prettyCookedOpt opts txOutRef + <+> "with script hash:" + <+> prettyHash opts scriptHash + <+> "; the full script must be provided through a matching reference input." prettyCookedOpt _ (MCEPastSlot current target) = "Unable to move back in time; current slot:" <+> PP.viaShow current diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index cbbe3e4b6..2e50ff648 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/src/Cooked/Pretty/Skeleton.hs @@ -66,6 +66,7 @@ instance PrettyCooked TxSkelCertificate where 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 (UserScriptHash sHash) = [Just ("Script" <+> prettyHash opt sHash)] prettyCookedOptListMaybe opt (UserRedeemedScript (toVScript -> script) red) = Just (prettyHash opt script) : prettyCookedOptListMaybe opt red diff --git a/src/Cooked/Skeleton/Output.hs b/src/Cooked/Skeleton/Output.hs index 02e6487ec..99126706c 100644 --- a/src/Cooked/Skeleton/Output.hs +++ b/src/Cooked/Skeleton/Output.hs @@ -149,6 +149,9 @@ instance IsTxSkelOutAllowedOwner Wallet where instance IsTxSkelOutAllowedOwner VScript where toPKHOrVScript = UserScript +instance IsTxSkelOutAllowedOwner Api.ScriptHash where + toPKHOrVScript = UserScriptHash + instance (Typeable a) => IsTxSkelOutAllowedOwner (Script.TypedValidator a) where toPKHOrVScript = UserScript diff --git a/src/Cooked/Skeleton/User.hs b/src/Cooked/Skeleton/User.hs index aa3280108..7a0cb0f60 100644 --- a/src/Cooked/Skeleton/User.hs +++ b/src/Cooked/Skeleton/User.hs @@ -83,6 +83,11 @@ data User :: UserKind -> UserMode -> Type where -- | 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 known only by its hash. This can be used whenever a script + -- is needed for the allocation mode but the full script is not available. + -- Spending an output owned by such a user requires providing the full script + -- through a reference input. + UserScriptHash :: forall kind. (kind ∈ '[IsScript, IsEither]) => Api.ScriptHash -> 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 @@ -93,6 +98,7 @@ type Peer = User IsPubKey Allocation instance Show (User kind mode) where show (UserPubKey (Script.toPubKeyHash -> pkh)) = "UserPubKey " <> show pkh show (UserScript (toVScript -> vScript)) = "UserScript " <> show (Script.toScriptHash vScript) + show (UserScriptHash sHash) = "UserScriptHash " <> show sHash show (UserRedeemedScript (toVScript -> vScript) red) = "UserRedeemedScript " <> show (Script.toScriptHash vScript) <> " " <> show red instance Eq (User kind mode) where @@ -100,17 +106,24 @@ instance Eq (User kind mode) where pkh == pkh' (UserScript (Script.toScriptHash . toVScript -> sHash)) == (UserScript (Script.toScriptHash . toVScript -> sHash')) = sHash == sHash' + (UserScriptHash sHash) == (UserScriptHash 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 {}) (UserScriptHash {}) = LT compare (UserPubKey {}) (UserRedeemedScript {}) = LT compare (UserScript {}) (UserPubKey {}) = GT + compare (UserScript {}) (UserScriptHash {}) = LT + compare (UserScriptHash {}) (UserPubKey {}) = GT + compare (UserScriptHash {}) (UserScript {}) = 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 (UserScriptHash sh) (UserScriptHash sh') = compare sh sh' compare (UserRedeemedScript (Script.toScriptHash . toVScript -> sh) red) (UserRedeemedScript (Script.toScriptHash . toVScript -> sh') red') = compare (sh, red) (sh', red') @@ -120,6 +133,7 @@ instance Script.ToPubKeyHash (User IsPubKey mode) where instance Script.ToCredential (User kind mode) where toCredential (UserPubKey (Script.toPubKeyHash -> pkh)) = Script.toCredential pkh toCredential (UserScript (toVScript -> vScript)) = Script.toCredential vScript + toCredential (UserScriptHash sHash) = Script.toCredential sHash toCredential (UserRedeemedScript (toVScript -> vScript) _) = Script.toCredential vScript instance Script.ToAddress (User kind mode) where @@ -134,6 +148,7 @@ userHashG = ( \case UserPubKey (Script.toPubKeyHash -> Api.PubKeyHash hs) -> hs UserScript (Script.toScriptHash . toVScript -> Api.ScriptHash hs) -> hs + UserScriptHash (Api.ScriptHash hs) -> hs UserRedeemedScript (Script.toScriptHash . toVScript -> Api.ScriptHash hs) _ -> hs ) @@ -144,6 +159,7 @@ userTypedAF = ( \case UserPubKey @user' pkh | Just Refl <- eqT @user @user' -> Just pkh UserScript @user' script | Just Refl <- eqT @user @user' -> Just script + UserScriptHash sHash | Just Refl <- eqT @user @Api.ScriptHash -> Just sHash UserRedeemedScript @user' script _ | Just Refl <- eqT @user @user' -> Just script _ -> Nothing ) @@ -230,7 +246,14 @@ userVScriptAT = -- | Retrieves the optional 'Api.ScriptHash' of a 'User' userScriptHashAF :: AffineFold (User kind mode) Api.ScriptHash -userScriptHashAF = userVScriptAT % to Script.toScriptHash +userScriptHashAF = + afolding + ( \case + UserScript (Script.toScriptHash . toVScript -> sHash) -> Just sHash + UserScriptHash sHash -> Just sHash + UserRedeemedScript (Script.toScriptHash . toVScript -> sHash) _ -> Just sHash + _ -> Nothing + ) -- | Focuses on the optional 'Api.PubKeyHash' of a 'User' userPubKeyHashAT :: AffineTraversal' (User kind mode) Api.PubKeyHash @@ -252,22 +275,22 @@ userPubKeyHashI = (\(UserPubKey (Script.toPubKeyHash -> pkh)) -> pkh) UserPubKey --- | Focuses on the 'VScript' of a script -userVScriptL :: Lens' (User IsScript mode) VScript +-- | Focuses on the 'VScript' of a redeemed script +userVScriptL :: Lens' (User IsScript Redemption) VScript userVScriptL = lens - ( \case - UserScript (toVScript -> vScript) -> vScript - UserRedeemedScript (toVScript -> vScript) _ -> vScript - ) - ( \case - UserScript _ -> UserScript - UserRedeemedScript _ red -> (`UserRedeemedScript` red) - ) + (\(UserRedeemedScript (toVScript -> vScript) _) -> vScript) + (\(UserRedeemedScript _ red) -> (`UserRedeemedScript` red)) -- | Retrieves the 'Api.ScriptHash' of a script userScriptHashG :: Getter (User IsScript mode) Api.ScriptHash -userScriptHashG = userVScriptL % to Script.toScriptHash +userScriptHashG = + to + ( \case + UserScript (Script.toScriptHash . toVScript -> sHash) -> sHash + UserScriptHash sHash -> sHash + UserRedeemedScript (Script.toScriptHash . toVScript -> sHash) _ -> sHash + ) -- | Focuses on the 'TxSkelRedeemer' of a script being redeemed userRedeemerL :: Lens' (User IsScript Redemption) TxSkelRedeemer From 673d6b72f5601351d97a3f6569ebd248de5d85fe Mon Sep 17 00:00:00 2001 From: mmontin Date: Mon, 3 Aug 2026 14:39:46 +0200 Subject: [PATCH 03/18] fixing missing cases in User, simplying a few optics there --- .gitignore | 1 + src/Cooked/Skeleton/User.hs | 25 +++++++++++-------------- 2 files changed, 12 insertions(+), 14 deletions(-) diff --git a/.gitignore b/.gitignore index 92ceffe9a..6940e17d8 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ dist-newstyle *.swp docs/ .pre-commit-config.yaml +.github/copilot-instructions.md diff --git a/src/Cooked/Skeleton/User.hs b/src/Cooked/Skeleton/User.hs index 7a0cb0f60..3e430f432 100644 --- a/src/Cooked/Skeleton/User.hs +++ b/src/Cooked/Skeleton/User.hs @@ -175,6 +175,7 @@ userTypedScriptAT = ) ( \case UserScript _ -> UserScript + UserScriptHash _ -> UserScript UserRedeemedScript _ red -> (`UserRedeemedScript` red) ) @@ -194,10 +195,12 @@ userEitherScriptP = prism ( \case UserScript script -> UserScript script + UserScriptHash sHash -> UserScriptHash sHash UserRedeemedScript script red -> UserRedeemedScript script red ) ( \case UserScript script -> Right (UserScript script) + UserScriptHash sHash -> Right (UserScriptHash sHash) UserRedeemedScript script red -> Right (UserRedeemedScript script red) user -> Left user ) @@ -275,13 +278,6 @@ userPubKeyHashI = (\(UserPubKey (Script.toPubKeyHash -> pkh)) -> pkh) UserPubKey --- | Focuses on the 'VScript' of a redeemed script -userVScriptL :: Lens' (User IsScript Redemption) VScript -userVScriptL = - lens - (\(UserRedeemedScript (toVScript -> vScript) _) -> vScript) - (\(UserRedeemedScript _ red) -> (`UserRedeemedScript` red)) - -- | Retrieves the 'Api.ScriptHash' of a script userScriptHashG :: Getter (User IsScript mode) Api.ScriptHash userScriptHashG = @@ -292,13 +288,6 @@ userScriptHashG = UserRedeemedScript (Script.toScriptHash . toVScript -> sHash) _ -> sHash ) --- | Focuses on the 'TxSkelRedeemer' of a script being redeemed -userRedeemerL :: Lens' (User IsScript Redemption) TxSkelRedeemer -userRedeemerL = - lens - (\(UserRedeemedScript _ red) -> red) - (\(UserRedeemedScript script _) -> UserRedeemedScript script) - -- | An isomorphism between a @User IsScript Redemption@ and a pair of 'VScript' -- and 'TxSkelRedeemer' userScriptRedeemerI :: Iso' (User IsScript Redemption) (VScript, TxSkelRedeemer) @@ -306,3 +295,11 @@ userScriptRedeemerI = iso (\(UserRedeemedScript (toVScript -> vScript) red) -> (vScript, red)) (uncurry UserRedeemedScript) + +-- | Focuses on the 'TxSkelRedeemer' of a script being redeemed +userRedeemerL :: Lens' (User IsScript Redemption) TxSkelRedeemer +userRedeemerL = userScriptRedeemerI % _2 + +-- | Focuses on the 'VScript' of a redeemed script +userVScriptL :: Lens' (User IsScript Redemption) VScript +userVScriptL = userScriptRedeemerI % _1 From 7f54ee051b00c99cedccb5b56ddbd6cc1c23d943 Mon Sep 17 00:00:00 2001 From: mmontin Date: Mon, 3 Aug 2026 18:50:40 +0200 Subject: [PATCH 04/18] first draft on an node interpreter for read effect --- cooked-validators.cabal | 2 + package.yaml | 2 + src/Cooked/MockChain/Effect/Read.hs | 231 ++++++++++++++++++++-------- 3 files changed, 175 insertions(+), 60 deletions(-) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 1a929ac8b..600cabf50 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -131,6 +131,7 @@ library , cardano-ledger-core , cardano-ledger-shelley , cardano-node-emulator + , cardano-slotting , cardano-strict-containers , containers , data-default @@ -154,6 +155,7 @@ library , tasty-hunit , tasty-quickcheck , text + , time default-language: Haskell2010 test-suite spec diff --git a/package.yaml b/package.yaml index c55466a87..d2faebcce 100644 --- a/package.yaml +++ b/package.yaml @@ -16,6 +16,7 @@ library: - cardano-ledger-shelley - cardano-ledger-conway - cardano-node-emulator + - cardano-slotting - cardano-strict-containers - containers - data-default @@ -39,6 +40,7 @@ library: - tasty-hunit - tasty-quickcheck - text + - time ghc-options: -Wall -Wcompat diff --git a/src/Cooked/MockChain/Effect/Read.hs b/src/Cooked/MockChain/Effect/Read.hs index d73d3a6d2..fab4772fa 100644 --- a/src/Cooked/MockChain/Effect/Read.hs +++ b/src/Cooked/MockChain/Effect/Read.hs @@ -6,6 +6,7 @@ module Cooked.MockChain.Effect.Read ( -- * The `MockChainRead` effect MockChainRead, runMockChainRead, + runMockChainReadNode, -- * Queries related to protocol parameters getParams, @@ -21,7 +22,7 @@ module Cooked.MockChain.Effect.Read txSkelInputScripts, txSkelInputValue, - -- * Queries related to timing + -- * Queries related to time currentSlot, currentMSRange, getEnclosingSlot, @@ -30,7 +31,6 @@ module Cooked.MockChain.Effect.Read slotToMSRange, -- * Queries related to fetching UTxOs - allUtxos, utxosAt, txSkelOutByRef, utxosFromCardanoTx, @@ -38,15 +38,27 @@ module Cooked.MockChain.Effect.Read previewByRef, viewByRef, - -- * Other queries - getConstitutionScript, + -- * Fetching reward amount query getCurrentReward, + + -- * The `MockChainReadExtra` effect + MockChainReadExtra (..), + runMockChainReadExtra, + + -- * Fetching all Utxos query + allUtxos, + + -- * Retrieving the full constitution script query + getConstitutionScript, ) where import Cardano.Api qualified as Cardano +import Cardano.Ledger.Conway qualified as Conway import Cardano.Ledger.Conway.Core qualified as Conway +import Cardano.Ledger.Core qualified as C.Ledger import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Cardano.Slotting.Time qualified as Time import Control.Lens qualified as Lens import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Credential (toStakeCredential) @@ -58,6 +70,9 @@ import Data.Coerce (coerce) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe +import Data.Set qualified as Set +import Data.Time.Clock (addUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Ledger.Slot qualified as P.Ledger import Ledger.Tx qualified as P.Ledger import Ledger.Tx.CardanoAPI qualified as P.Ledger @@ -67,18 +82,19 @@ import PlutusLedgerApi.V3 qualified as Api import Polysemy import Polysemy.Error import Polysemy.Fail +import Polysemy.Reader import Polysemy.State -- | An effect that offers primitives to query the current state of the -- mockchain. As its name suggests, this effect is read-only and does not alter -- the state in any way. data MockChainRead :: Effect where - GetParams :: MockChainRead m Emulator.Params + GetParams :: MockChainRead m (C.Ledger.PParams Conway.ConwayEra) TxSkelOutByRef :: Api.TxOutRef -> MockChainRead m TxSkelOut CurrentSlot :: MockChainRead m P.Ledger.Slot - AllUtxos :: MockChainRead m Utxos + SlotToMSRange :: P.Ledger.Slot -> MockChainRead m (Api.POSIXTime, Api.POSIXTime) + GetEnclosingSlot :: Api.POSIXTime -> MockChainRead m P.Ledger.Slot UtxosAt :: (Script.ToCredential a) => a -> MockChainRead m Utxos - GetConstitutionScript :: MockChainRead m (Maybe VScript) GetCurrentReward :: (Script.ToCredential c) => c -> MockChainRead m (Maybe Api.Lovelace) makeSem_ ''MockChainRead @@ -89,23 +105,34 @@ runMockChainRead :: ( Members '[ State MockChainState, Error P.Ledger.ToCardanoError, - Error MockChainError + Error MockChainError, + Fail ] effs ) => Sem (MockChainRead : effs) a -> Sem effs a runMockChainRead = interpret $ \case - GetParams -> gets mcstParams + GetParams -> gets $ Emulator.pEmulatorPParams . mcstParams TxSkelOutByRef oRef -> do res <- gets $ Map.lookup oRef . mcstOutputs case res of Just (txSkelOut, True) -> return txSkelOut _ -> throw $ MCEUnknownOutRef oRef - AllUtxos -> fetchUtxos $ const True UtxosAt (Script.toCredential -> cred) -> fetchUtxos $ (== cred) . Script.toCredential CurrentSlot -> gets $ view $ mcstLedgerStateL % to Emulator.getSlot - GetConstitutionScript -> gets $ view mcstConstitutionL + SlotToMSRange slot -> do + slotConfig <- gets $ Emulator.pSlotConfig . mcstParams + case Emulator.slotToPOSIXTimeRange slotConfig slot of + Api.Interval + (Api.LowerBound (Api.Finite l) leftclosed) + (Api.UpperBound (Api.Finite r) rightclosed) -> + return + ( if leftclosed then l else l + 1, + if rightclosed then r else r - 1 + ) + _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" + GetEnclosingSlot t -> gets $ (`Emulator.posixTimeToEnclosingSlot` t) . Emulator.pSlotConfig . mcstParams GetCurrentReward (Script.toCredential -> cred) -> do stakeCredential <- toStakeCredential cred gets $ @@ -128,7 +155,7 @@ runMockChainRead = interpret $ \case -- | Returns the emulator parameters, including protocol parameters getParams :: (Member MockChainRead effs) => - Sem effs Emulator.Params + Sem effs (C.Ledger.PParams Conway.ConwayEra) -- | Retrieves the required governance action deposit amount govActionDeposit :: @@ -139,7 +166,6 @@ govActionDeposit = <&> Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppGovActionDepositL - . Emulator.emulatorPParams -- | Retrieves the required drep deposit amount dRepDeposit :: @@ -150,7 +176,6 @@ dRepDeposit = <&> Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppDRepDepositL - . Emulator.emulatorPParams -- | Retrieves the required stake address deposit amount stakeAddressDeposit :: @@ -161,7 +186,6 @@ stakeAddressDeposit = <&> Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppKeyDepositL - . Emulator.emulatorPParams -- | Retrieves the required stake pool deposit amount stakePoolDeposit :: @@ -172,7 +196,6 @@ stakePoolDeposit = <&> Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppPoolDepositL - . Emulator.emulatorPParams -- | Retrieves the total amount of lovelace deposited in certificates in this -- skeleton. Note that unregistering a staking address or a dRep lead to a @@ -256,6 +279,13 @@ currentSlot :: (Member MockChainRead effs) => Sem effs P.Ledger.Slot +-- | Returns the closed ms interval corresponding to the slot with the given +-- number. +slotToMSRange :: + (Members '[MockChainRead, Fail] effs) => + P.Ledger.Slot -> + Sem effs (Api.POSIXTime, Api.POSIXTime) + -- | Returns the closed ms interval corresponding to the current slot currentMSRange :: (Members '[MockChainRead, Fail] effs) => @@ -268,10 +298,6 @@ getEnclosingSlot :: (Member MockChainRead effs) => Api.POSIXTime -> Sem effs P.Ledger.Slot -getEnclosingSlot t = - getParams - <&> (`Emulator.posixTimeToEnclosingSlot` t) - . Emulator.pSlotConfig -- | The infinite range of slots ending before or at the given time slotRangeBefore :: @@ -296,41 +322,6 @@ slotRangeAfter t = do (a, _) <- slotToMSRange n return $ Api.from $ if t == a then n else n + 1 --- | Returns the closed ms interval corresponding to the slot with the given --- number. It holds that --- --- > slotToMSRange (getEnclosingSlot t) == (a, b) ==> a <= t <= b --- --- and --- --- > slotToMSRange n == (a, b) ==> getEnclosingSlot a == n && getEnclosingSlot b == n --- --- and --- --- > slotToMSRange n == (a, b) ==> getEnclosingSlot (a-1) == n-1 && getEnclosingSlot (b+1) == n+1 -slotToMSRange :: - ( Members '[MockChainRead, Fail] effs, - Integral i - ) => - i -> - Sem effs (Api.POSIXTime, Api.POSIXTime) -slotToMSRange (fromIntegral -> slot) = do - slotConfig <- Emulator.pSlotConfig <$> getParams - case Emulator.slotToPOSIXTimeRange slotConfig slot of - Api.Interval - (Api.LowerBound (Api.Finite l) leftclosed) - (Api.UpperBound (Api.Finite r) rightclosed) -> - return - ( if leftclosed then l else l + 1, - if rightclosed then r else r - 1 - ) - _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" - --- | Returns a list of all currently known outputs -allUtxos :: - (Member MockChainRead effs) => - Sem effs Utxos - -- | Returns a list of all UTxOs at a certain address. utxosAt :: ( Member MockChainRead effs, @@ -390,11 +381,6 @@ previewByRef :: Sem effs (Maybe c) previewByRef optic = (preview optic <$>) . txSkelOutByRef --- | Gets the current official constitution script -getConstitutionScript :: - (Member MockChainRead effs) => - Sem effs (Maybe VScript) - -- | Gets the current reward associated with a credential getCurrentReward :: ( Member MockChainRead effs, @@ -402,3 +388,128 @@ getCurrentReward :: ) => c -> Sem effs (Maybe Api.Lovelace) + +data MockChainReadExtra :: Effect where + AllUtxos :: MockChainReadExtra m Utxos + GetConstitutionScript :: MockChainReadExtra m (Maybe VScript) + +makeSem_ ''MockChainReadExtra + +runMockChainReadExtra :: + forall effs a. + ( Members + '[ State MockChainState, + Error P.Ledger.ToCardanoError, + Error MockChainError, + Fail + ] + effs + ) => + Sem (MockChainReadExtra : effs) a -> + Sem effs a +runMockChainReadExtra = interpret $ \case + AllUtxos -> gets $ toListOf $ mcstOutputsL % to Map.toList % traversed % filtered (snd . snd) % to (fmap fst) + GetConstitutionScript -> gets $ view mcstConstitutionL + +-- | Returns a list of all currently known outputs +allUtxos :: + (Member MockChainReadExtra effs) => + Sem effs Utxos + +-- | Gets the current official constitution script +getConstitutionScript :: + (Member MockChainReadExtra effs) => + Sem effs (Maybe VScript) + +-- * Interpreting `MockChainRead` against a deployed node + +-- NOTE: The following is a first sketch of an interpretation of `MockChainRead` +-- against a real, deployed Cardano node, using `cardano-api`'s local-state +-- query and chain-sync protocols. The primitives that map directly onto +-- `cardano-api` queries are implemented; the ones that require rebuilding a +-- `TxSkelOut` from an on-chain output (as well as credential-based address +-- filtering and the exact credential conversion) are left as clearly marked +-- `TODO`s to be refined. + +-- | Interpret the `MockChainRead` effect by talking to a deployed node through +-- a `Cardano.LocalNodeConnectInfo` (socket path and network id) provided via a +-- `Reader`, running in a stack featuring @IO@ (via `Embed`). Failures are +-- surfaced through the corresponding typed `Error` effects rather than being +-- collapsed into generic failures. +runMockChainReadNode :: + forall effs a. + ( Members + '[ Embed IO, + Error Cardano.UnsupportedNtcVersionError, + Error Cardano.EraMismatch, + Error Cardano.AcquiringFailure, + Error Cardano.PastHorizonException, + Error P.Ledger.ToCardanoError, + Reader Cardano.LocalNodeConnectInfo + ] + effs + ) => + Sem (MockChainRead : effs) a -> + Sem effs a +runMockChainReadNode = interpret $ \case + -- Protocol parameters: a plain shelley-based-era query. + GetParams -> querySbe $ Cardano.queryProtocolParameters Cardano.ShelleyBasedEraConway + -- The current slot is read from the chain tip. + CurrentSlot -> ask >>= fmap chainTipSlot . embed . Cardano.getLocalChainTip + -- Slot -> closed ms interval, computed from the era history and system start. + SlotToMSRange slot -> do + eraHistory <- execExpr Cardano.queryEraHistory >>= fromEither + systemStart <- execExpr Cardano.querySystemStart >>= fromEither + (relStart, slotLen) <- fromEither $ Cardano.getProgress (toSlotNo slot) eraHistory + let startUTC = Time.fromRelativeTime systemStart relStart + endUTC = addUTCTime (Time.getSlotLength slotLen) startUTC + -- TODO: refine the closed-interval boundary handling (the emulator returns + -- an inclusive ms interval; here we take [start, start + slotLength]). + return (utcToPOSIXTime startUTC, utcToPOSIXTime endUTC) + -- POSIXTime -> enclosing slot, via the era history interpreter. + GetEnclosingSlot t -> do + eraHistory <- execExpr Cardano.queryEraHistory >>= fromEither + systemStart <- execExpr Cardano.querySystemStart >>= fromEither + let relTime = Time.toRelativeTime systemStart (posixTimeToUTC t) + fromSlotNo <$> fromEither (Cardano.getSlotForRelativeTime relTime eraHistory) + -- All UTxOs owned by a credential. + UtxosAt _cred -> do + -- TODO: filter node-side by address. A credential alone does not determine + -- an address (the staking part is unknown), and `QueryUTxOByAddress` takes + -- full addresses. For now we query the whole set and would filter + -- client-side by `Script.toCredential cred` once `txSkelOutFromApiTxOut` is + -- implemented. Querying the whole UTxO set is expensive: refine later. + utxo <- queryUtxos Cardano.QueryUTxOWhole + mapM convertUtxo (Map.toList (Cardano.unUTxO utxo)) + -- A single output, resolved by its reference. + TxSkelOutByRef oRef -> do + txIn <- fromEither $ P.Ledger.toCardanoTxIn oRef + utxo <- queryUtxos $ Cardano.QueryUTxOByTxIn $ Set.singleton txIn + case Map.elems (Cardano.unUTxO utxo) of + [txOut] -> txSkelOutFromApiTxOut txOut + -- TODO: decide how a missing UTxO should be signalled by the node backend. + _ -> error "runMockChainReadNode: TxSkelOutByRef on a missing UTxO" + -- The current reward accumulated by a credential's stake address. + GetCurrentReward (Script.toCredential -> cred) -> do + networkId <- asks Cardano.localNodeNetworkId + let stakeCred = toCardanoStakeCredential cred + stakeAddr = Cardano.makeStakeAddress networkId stakeCred + (rewards, _) <- querySbe $ Cardano.queryStakeAddresses Cardano.ShelleyBasedEraConway (Set.singleton stakeCred) networkId + return $ Api.Lovelace . Cardano.unCoin <$> Map.lookup stakeAddr rewards + where + execExpr expr = ask >>= \conn -> embed (Cardano.executeLocalStateQueryExpr conn Cardano.VolatileTip expr) >>= fromEither + querySbe expr = execExpr expr >>= fromEither >>= fromEither + queryUtxos flt = querySbe (Cardano.queryUtxo Cardano.ShelleyBasedEraConway flt) + chainTipSlot Cardano.ChainTipAtGenesis = P.Ledger.Slot 0 + chainTipSlot (Cardano.ChainTip slotNo _ _) = fromSlotNo slotNo + toSlotNo = Cardano.SlotNo . fromInteger . P.Ledger.getSlot + fromSlotNo (Cardano.SlotNo w) = P.Ledger.Slot (toInteger w) + posixTimeToUTC t = posixSecondsToUTCTime (fromRational (toRational (Api.getPOSIXTime t) / 1000)) + utcToPOSIXTime u = Api.POSIXTime (round (1000 * utcTimeToPOSIXSeconds u)) + convertUtxo (txIn, txOut) = (P.Ledger.fromCardanoTxIn txIn,) <$> txSkelOutFromApiTxOut txOut + -- TODO: reconstruct a `TxSkelOut` from an on-chain output (owner and staking + -- credentials from the address, value, datum, reference script). + txSkelOutFromApiTxOut _ = error "txSkelOutFromApiTxOut: not implemented yet" + -- TODO: convert a Plutus credential into a `Cardano.StakeCredential` + -- (`toStakeCredential`, already imported, may be reusable here). + toCardanoStakeCredential _ = error "toCardanoStakeCredential: not implemented yet" From 519770af94f68dc54bfb10dc69ef49b9e0439c73 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Aug 2026 02:26:02 +0200 Subject: [PATCH 05/18] still processing Read ... and the riples --- cooked-validators.cabal | 1 + package.yaml | 1 + .../Automation/AutoFilling/MinAda.hs | 3 +- src/Cooked/MockChain/Automation/Balancing.hs | 9 +- .../MockChain/Automation/GenerateTx/Body.hs | 79 +++-- .../Automation/GenerateTx/Certificate.hs | 3 +- .../MockChain/Automation/GenerateTx/Output.hs | 3 +- .../Automation/GenerateTx/Withdrawals.hs | 3 +- src/Cooked/MockChain/Effect/Read.hs | 271 +++++++++++------- src/Cooked/MockChain/Effect/Write.hs | 4 +- src/Cooked/MockChain/Runtime/Error.hs | 2 +- src/Cooked/MockChain/UtxoSearch.hs | 2 +- src/Cooked/Skeleton/Datum.hs | 15 + src/Cooked/Skeleton/Proposal.hs | 4 +- src/Cooked/Skeleton/User.hs | 11 + 15 files changed, 253 insertions(+), 158 deletions(-) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 600cabf50..5fbb243ee 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -127,6 +127,7 @@ library , bytestring , cardano-api , cardano-crypto + , cardano-ledger-alonzo , cardano-ledger-conway , cardano-ledger-core , cardano-ledger-shelley diff --git a/package.yaml b/package.yaml index d2faebcce..75315dd3c 100644 --- a/package.yaml +++ b/package.yaml @@ -12,6 +12,7 @@ library: - bytestring - cardano-api - cardano-crypto + - cardano-ledger-alonzo - cardano-ledger-core - cardano-ledger-shelley - cardano-ledger-conway diff --git a/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs b/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs index 2d5e2112c..b4547f59e 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs +++ b/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs @@ -10,7 +10,6 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Shelley.Core qualified as Shelley -import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Output import Cooked.MockChain.Effect.Log @@ -32,7 +31,7 @@ getTxSkelOutMinAda :: TxSkelOut -> Sem effs Integer getTxSkelOutMinAda txSkelOut = do - params <- Emulator.pEmulatorPParams <$> getParams + params <- getParams Cardano.unCoin . Shelley.getMinCoinTxOut params . Cardano.toShelleyTxOut Cardano.ShelleyBasedEraConway diff --git a/src/Cooked/MockChain/Automation/Balancing.hs b/src/Cooked/MockChain/Automation/Balancing.hs index 8f6502da3..8be53c93f 100644 --- a/src/Cooked/MockChain/Automation/Balancing.hs +++ b/src/Cooked/MockChain/Automation/Balancing.hs @@ -14,7 +14,6 @@ import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway -import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad import Cooked.MockChain.Automation.AutoFilling.MinAda import Cooked.MockChain.Automation.GenerateTx.Body @@ -233,7 +232,7 @@ collateralsFromFee :: collateralsFromFee _ Nothing = return Nothing collateralsFromFee fee (Just (collateralIns, returnCollateralUser)) = do -- We retrieve the protocol parameters - params <- Emulator.pEmulatorPParams <$> getParams + params <- getParams -- We retrieve the max number of collateral inputs, with a default of 10. In -- practice this will be around 3. let nbMax = toInteger $ Microlens.view Conway.ppMaxCollateralInputsL params @@ -276,7 +275,7 @@ reachValue :: reachValue utxos target fuel outputOrUser = do -- We retrieve the current protocol version, which is going to be used to -- compute the size of the inputs and outputs added by this function - Cardano.ProtVer majorVersion _ <- Microlens.view Conway.ppProtocolVersionL . Emulator.emulatorPParams <$> getParams + Cardano.ProtVer majorVersion _ <- Microlens.view Conway.ppProtocolVersionL <$> getParams -- We annotate @outputOrUser@ with the size of the existing output, if any outputOrUser' <- case outputOrUser of Left output -> Left . (output,) <$> outputSize majorVersion output @@ -398,7 +397,7 @@ estimateTxSkelFee :: Sem effs (Fee, Body) estimateTxSkelFee skel fee mCollaterals = do -- We retrieve the necessary data to generate the transaction body - params <- Emulator.pEmulatorPParams <$> getParams + params <- getParams -- We build the index known to the skeleton index <- txSkelToIndex skel mCollaterals -- We build the transaction body @@ -504,7 +503,7 @@ getMinAndMaxFee :: getMinAndMaxFee nbOfScripts = do -- We retrieve the necessary parameters to compute the maximum possible fee -- for a transaction. There are quite a few of them. - params <- Emulator.pEmulatorPParams <$> getParams + params <- getParams let maxTxSize = toInteger $ Microlens.view Conway.ppMaxTxSizeL params Cardano.Coin txFeePerByte = Microlens.view Conway.ppMinFeeAL params Cardano.Coin txFeeFixed = Microlens.view Conway.ppMinFeeBL params diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs index 1019f7c8b..d4c10e870 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs @@ -11,7 +11,7 @@ module Cooked.MockChain.Automation.GenerateTx.Body where import Cardano.Api qualified as Cardano -import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Certificate import Cooked.MockChain.Automation.GenerateTx.Collateral @@ -26,12 +26,16 @@ import Cooked.MockChain.Common import Cooked.MockChain.Effect.Read import Cooked.MockChain.Runtime.Error import Cooked.Skeleton +import Data.Bifunctor (first) import Data.Map qualified as Map import Data.Maybe import Data.Set qualified as Set +import Data.Text qualified as Text import Ledger.Address qualified as P.Ledger +import Ledger.Index qualified as P.Ledger import Ledger.Tx.CardanoAPI qualified as P.Ledger import Plutus.Script.Utils.Address qualified as Script +import PlutusLedgerApi.V1 qualified as Api import Polysemy import Polysemy.Error import Polysemy.Fail @@ -57,7 +61,7 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do Cardano.TxExtraKeyWitnesses Cardano.AlonzoEraOnwardsConway <$> fromEither (mapM (P.Ledger.toCardanoPaymentKeyHash . P.Ledger.PaymentPubKeyHash . Script.toPubKeyHash) txSkelSignatories) - txProtocolParams <- Cardano.BuildTxWith . Just . Emulator.ledgerProtocolParameters <$> getParams + txProtocolParams <- Cardano.BuildTxWith . Just . Cardano.LedgerProtocolParameters <$> getParams txProposalProcedures <- Just . Cardano.Featured Cardano.ConwayEraOnwardsConway <$> toProposalProcedures txSkelProposals txWithdrawals <- toWithdrawals txSkelWithdrawals txCertificates <- toCertificates txSkelCertificates @@ -73,13 +77,13 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do -- | Generates a transaction body from a body content txBodyContentToTxBody :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Member (Error P.Ledger.ToCardanoError) effs) => Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra -> Sem effs (Cardano.TxBody Cardano.ConwayEra) -txBodyContentToTxBody txBodyContent = do - params <- getParams - -- We create the associated Shelley TxBody - fromEither $ Emulator.createTransactionBody params $ P.Ledger.CardanoBuildTx txBodyContent +txBodyContentToTxBody = + fromEither + . first (P.Ledger.TxBodyError . Cardano.displayError) + . Cardano.createTransactionBody Cardano.shelleyBasedEra -- | Generates an index with utxos known to a 'TxSkel' txSkelToIndex :: @@ -113,30 +117,49 @@ txSkelToTxBody txSkel fee mCollaterals = do txBodyContent' <- txSkelToTxBodyContent txSkel fee mCollaterals txBody' <- txBodyContentToTxBody txBodyContent' -- We create a full transaction from the body - let tx' = txSignatoriesAndBodyToCardanoTx (txSkelSignatories txSkel) txBody' + let (Cardano.ShelleyTx _ tx) = txSignatoriesAndBodyToCardanoTx (txSkelSignatories txSkel) txBody' -- We retrieve the index and parameters to feed to @getTxExUnitsWithLogs@ index <- txSkelToIndex txSkel mCollaterals params <- getParams - -- We retrieve the execution units associated with the transaction - case Emulator.getTxExUnitsWithLogs params (P.Ledger.fromPlutusIndex index) tx' of - -- Computing the execution units can result in all kinds of phase 2 - -- validation failures, except for the ones related to the execution units - -- themselves. Unless required in the options, we throw the validation - -- failure right away when applicable. - Left err | not $ txSkelOptDeferPhase2FailuresDuringBalancing $ txSkelOpts txSkel -> throw $ uncurry MCEValidationError err - -- The other option is to ignore those and return the unchanged body with - -- the existing execution units, postponing the handling of the failures. - Left _ -> return txBody' - -- When no error arises, we get an execution unit for each script usage. We - -- first have to transform this Ledger map to a cardano API map. - Right (Map.mapKeysMonotonic (Cardano.toScriptIndex Cardano.AlonzoEraOnwardsConway) . fmap (Cardano.fromAlonzoExUnits . snd) -> exUnits) -> - -- We can then assign the right execution units to the body content - case Cardano.substituteExecutionUnits exUnits txBodyContent' of - -- This can only be a @TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap@ - Left err -> throw $ MCEFailure $ "Error while assigning execution units: " <> show err - -- We now have a body content with proper execution units and can create - -- the final body from it - Right txBodyContent -> txBodyContentToTxBody txBodyContent + epochInfo <- Cardano.unLedgerEpochInfo . Cardano.toLedgerEpochInfo <$> getEraHistory + systemStart <- getSystemStart + -- We compute the execution units associated with the transaction and process + -- the result by splitting successful cases from errors. + let exUnitsReport = Alonzo.evalTxExUnits params tx (P.Ledger.fromPlutusIndex index) epochInfo systemStart + (success, errors) = + foldl + ( \(sucs, errs) (purpose, report) -> case report of + Right exUnits -> + ( Map.insert (Cardano.toScriptIndex Cardano.AlonzoEraOnwardsConway purpose) (Cardano.fromAlonzoExUnits exUnits) sucs, + errs + ) + Left err -> + ( success, + ( P.Ledger.Phase2, + case err of + Alonzo.ValidationFailure _ (Api.CekError e) logs _ -> P.Ledger.ScriptFailure (Api.EvaluationError logs ("CekEvaluationFailure: " ++ show e)) + e -> P.Ledger.CardanoLedgerValidationError $ Text.pack $ show e + ) + : errs + ) + ) + (Map.empty, []) + (Map.toList exUnitsReport) + -- Computing the execution units can result in all phase 2 validation + -- failures, except for the ones related to the execution units themselves. + case errors of + -- No validation failures detected, we assigne the execution units. + [] -> case Cardano.substituteExecutionUnits success txBodyContent' of + -- This can only be a @TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap@ + Left err -> throw $ MCEFailure $ "Error while assigning execution units: " <> show err + -- We now have a body content with proper execution units and can create + -- the final body from it + Right txBodyContent -> txBodyContentToTxBody txBodyContent + -- Some validation failures detected, and they should be handled + l | not $ txSkelOptDeferPhase2FailuresDuringBalancing $ txSkelOpts txSkel -> throw $ MCEValidationError l + -- Some validation failures detected, which should be deferred. We ignore + -- them and return the current body without assigning execution units. + _ -> return txBody' -- | Generates a Cardano transaction and signs it txSignatoriesAndBodyToCardanoTx :: diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs b/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs index 7cfb0707c..408fddb24 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs @@ -7,7 +7,6 @@ import Cardano.Ledger.Conway.TxCert qualified as Conway import Cardano.Ledger.DRep qualified as C.Ledger import Cardano.Ledger.PoolParams qualified as C.Ledger import Cardano.Ledger.Shelley.TxCert qualified as Shelley -import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Cooked.MockChain.Automation.GenerateTx.Credential import Cooked.MockChain.Automation.GenerateTx.Witness import Cooked.MockChain.Effect.Read @@ -77,7 +76,7 @@ toCertificate txSkelCert = Shelley.RetirePool (toStakePoolKeyHash poolHash) ( do - eeh <- Emulator.emulatorEraHistory <$> getParams + eeh <- getEraHistory 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 diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs b/src/Cooked/MockChain/Automation/GenerateTx/Output.hs index 561d9b2b7..8f99e2dad 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Output.hs @@ -2,7 +2,6 @@ module Cooked.MockChain.Automation.GenerateTx.Output (toCardanoTxOut) where import Cardano.Api qualified as Cardano -import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Cooked.MockChain.Effect.Read import Cooked.Skeleton.Datum import Cooked.Skeleton.Output @@ -23,7 +22,7 @@ toCardanoTxOut output = do oValue = view txSkelOutValueL output oDatum = view txSkelOutDatumL output oRefScript = view txSkelOutMReferenceScriptL output - networkId <- Emulator.pNetworkId <$> getParams + networkId <- getNetworkId address <- fromEither $ P.Ledger.toCardanoAddressInEra networkId oAddress (P.Ledger.toCardanoTxOutValue -> value) <- fromEither $ P.Ledger.toCardanoValue oValue datum <- case oDatum of diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs b/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs index 0727d021a..ff8f41328 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs @@ -2,7 +2,6 @@ module Cooked.MockChain.Automation.GenerateTx.Withdrawals (toWithdrawals) where import Cardano.Api qualified as Cardano -import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Witness import Cooked.MockChain.Effect.Read @@ -25,7 +24,7 @@ toWithdrawals :: Sem effs (Cardano.TxWithdrawals Cardano.BuildTx Cardano.ConwayEra) toWithdrawals withdrawals | withdrawals == mempty = return Cardano.TxWithdrawalsNone toWithdrawals (view txSkelWithdrawalsListI -> withdrawals) = do - networkId <- Emulator.pNetworkId <$> getParams + networkId <- getNetworkId cardanoWithdrawals <- forM withdrawals $ \(Withdrawal user amount) -> do let coinAmount = maybe (Cardano.Coin 0) coerce amount (sCred, witness) <- case user of diff --git a/src/Cooked/MockChain/Effect/Read.hs b/src/Cooked/MockChain/Effect/Read.hs index fab4772fa..9857f272a 100644 --- a/src/Cooked/MockChain/Effect/Read.hs +++ b/src/Cooked/MockChain/Effect/Read.hs @@ -3,13 +3,16 @@ -- | This module exposes primitives to query the current state of the -- blockchain. module Cooked.MockChain.Effect.Read - ( -- * The `MockChainRead` effect + ( -- * The 'MockChainRead' effect MockChainRead, - runMockChainRead, + + -- * 'MockChainRead' interpreters + runMockChainReadEmul, runMockChainReadNode, -- * Queries related to protocol parameters getParams, + getNetworkId, govActionDeposit, dRepDeposit, stakeAddressDeposit, @@ -25,12 +28,15 @@ module Cooked.MockChain.Effect.Read -- * Queries related to time currentSlot, currentMSRange, + getEraHistory, + getSystemStart, getEnclosingSlot, slotRangeBefore, slotRangeAfter, slotToMSRange, -- * Queries related to fetching UTxOs + allUtxos, utxosAt, txSkelOutByRef, utxosFromCardanoTx, @@ -38,46 +44,45 @@ module Cooked.MockChain.Effect.Read previewByRef, viewByRef, - -- * Fetching reward amount query + -- * Query fetching the current reward amount getCurrentReward, - -- * The `MockChainReadExtra` effect - MockChainReadExtra (..), - runMockChainReadExtra, - - -- * Fetching all Utxos query - allUtxos, - - -- * Retrieving the full constitution script query + -- * Query fetching the current full constitution script getConstitutionScript, ) where import Cardano.Api qualified as Cardano +import Cardano.Api.Ledger qualified as Cardano hiding (TxIn) import Cardano.Ledger.Conway qualified as Conway import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Ledger.Core qualified as C.Ledger +import Cardano.Ledger.Shelley.API qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Cardano.Slotting.Time qualified as Time import Control.Lens qualified as Lens import Control.Monad -import Cooked.MockChain.Automation.GenerateTx.Credential (toStakeCredential) +import Cooked.MockChain.Automation.GenerateTx.Credential import Cooked.MockChain.Common import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton +import Data.Bifunctor import Data.Coerce (coerce) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe +import Data.Maybe.Strict import Data.Set qualified as Set -import Data.Time.Clock (addUTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Ledger.Address qualified as P.Ledger import Ledger.Slot qualified as P.Ledger import Ledger.Tx qualified as P.Ledger import Ledger.Tx.CardanoAPI qualified as P.Ledger 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 import Polysemy import Polysemy.Error @@ -90,17 +95,22 @@ import Polysemy.State -- the state in any way. data MockChainRead :: Effect where GetParams :: MockChainRead m (C.Ledger.PParams Conway.ConwayEra) + GetNetworkId :: MockChainRead m Cardano.NetworkId TxSkelOutByRef :: Api.TxOutRef -> MockChainRead m TxSkelOut CurrentSlot :: MockChainRead m P.Ledger.Slot + GetEraHistory :: MockChainRead m Cardano.EraHistory + GetSystemStart :: MockChainRead m Time.SystemStart SlotToMSRange :: P.Ledger.Slot -> MockChainRead m (Api.POSIXTime, Api.POSIXTime) GetEnclosingSlot :: Api.POSIXTime -> MockChainRead m P.Ledger.Slot - UtxosAt :: (Script.ToCredential a) => a -> MockChainRead m Utxos + AllUtxos :: MockChainRead m Utxos + UtxosAt :: (Script.ToAddress a) => a -> MockChainRead m Utxos + GetConstitutionScript :: MockChainRead m (Maybe VScript) GetCurrentReward :: (Script.ToCredential c) => c -> MockChainRead m (Maybe Api.Lovelace) makeSem_ ''MockChainRead --- | The interpretation for read-only effect in the blockchain state -runMockChainRead :: +-- | The interpretation for read-only effect with a stored 'MockChainState' +runMockChainReadEmul :: forall effs a. ( Members '[ State MockChainState, @@ -112,15 +122,19 @@ runMockChainRead :: ) => Sem (MockChainRead : effs) a -> Sem effs a -runMockChainRead = interpret $ \case +runMockChainReadEmul = interpret $ \case GetParams -> gets $ Emulator.pEmulatorPParams . mcstParams + GetNetworkId -> gets $ Emulator.pNetworkId . mcstParams TxSkelOutByRef oRef -> do res <- gets $ Map.lookup oRef . mcstOutputs case res of Just (txSkelOut, True) -> return txSkelOut _ -> throw $ MCEUnknownOutRef oRef - UtxosAt (Script.toCredential -> cred) -> fetchUtxos $ (== cred) . Script.toCredential + AllUtxos -> fetchUtxos $ const True + UtxosAt (Script.toAddress -> addr) -> fetchUtxos $ (== addr) . Script.toAddress CurrentSlot -> gets $ view $ mcstLedgerStateL % to Emulator.getSlot + GetEraHistory -> gets $ Emulator.emulatorEraHistory . mcstParams + GetSystemStart -> gets $ Shelley.systemStart . Emulator.emulatorGlobals . mcstParams SlotToMSRange slot -> do slotConfig <- gets $ Emulator.pSlotConfig . mcstParams case Emulator.slotToPOSIXTimeRange slotConfig slot of @@ -133,6 +147,7 @@ runMockChainRead = interpret $ \case ) _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" GetEnclosingSlot t -> gets $ (`Emulator.posixTimeToEnclosingSlot` t) . Emulator.pSlotConfig . mcstParams + GetConstitutionScript -> gets $ view mcstConstitutionL GetCurrentReward (Script.toCredential -> cred) -> do stakeCredential <- toStakeCredential cred gets $ @@ -157,6 +172,11 @@ getParams :: (Member MockChainRead effs) => Sem effs (C.Ledger.PParams Conway.ConwayEra) +-- | Returns the network id of the current chain +getNetworkId :: + (Member MockChainRead effs) => + Sem effs Cardano.NetworkId + -- | Retrieves the required governance action deposit amount govActionDeposit :: (Member MockChainRead effs) => @@ -279,6 +299,18 @@ currentSlot :: (Member MockChainRead effs) => Sem effs P.Ledger.Slot +-- | Returns the era history of the chain, which notably allows converting slots +-- into epochs (see 'Cardano.slotToEpoch'). +getEraHistory :: + (Member MockChainRead effs) => + Sem effs Cardano.EraHistory + +-- | Returns the system start time of the chain, that is the UTC time at which +-- the first slot begins. +getSystemStart :: + (Member MockChainRead effs) => + Sem effs Time.SystemStart + -- | Returns the closed ms interval corresponding to the slot with the given -- number. slotToMSRange :: @@ -322,10 +354,15 @@ slotRangeAfter t = do (a, _) <- slotToMSRange n return $ Api.from $ if t == a then n else n + 1 +-- | Returns a list of all currently known outputs +allUtxos :: + (Member MockChainRead effs) => + Sem effs Utxos + -- | Returns a list of all UTxOs at a certain address. utxosAt :: ( Member MockChainRead effs, - Script.ToCredential cred + Script.ToAddress cred ) => cred -> Sem effs Utxos @@ -381,6 +418,11 @@ previewByRef :: Sem effs (Maybe c) previewByRef optic = (preview optic <$>) . txSkelOutByRef +-- | Gets the current official constitution script +getConstitutionScript :: + (Member MockChainRead effs) => + Sem effs (Maybe VScript) + -- | Gets the current reward associated with a credential getCurrentReward :: ( Member MockChainRead effs, @@ -389,53 +431,9 @@ getCurrentReward :: c -> Sem effs (Maybe Api.Lovelace) -data MockChainReadExtra :: Effect where - AllUtxos :: MockChainReadExtra m Utxos - GetConstitutionScript :: MockChainReadExtra m (Maybe VScript) - -makeSem_ ''MockChainReadExtra - -runMockChainReadExtra :: - forall effs a. - ( Members - '[ State MockChainState, - Error P.Ledger.ToCardanoError, - Error MockChainError, - Fail - ] - effs - ) => - Sem (MockChainReadExtra : effs) a -> - Sem effs a -runMockChainReadExtra = interpret $ \case - AllUtxos -> gets $ toListOf $ mcstOutputsL % to Map.toList % traversed % filtered (snd . snd) % to (fmap fst) - GetConstitutionScript -> gets $ view mcstConstitutionL - --- | Returns a list of all currently known outputs -allUtxos :: - (Member MockChainReadExtra effs) => - Sem effs Utxos - --- | Gets the current official constitution script -getConstitutionScript :: - (Member MockChainReadExtra effs) => - Sem effs (Maybe VScript) - --- * Interpreting `MockChainRead` against a deployed node - --- NOTE: The following is a first sketch of an interpretation of `MockChainRead` --- against a real, deployed Cardano node, using `cardano-api`'s local-state --- query and chain-sync protocols. The primitives that map directly onto --- `cardano-api` queries are implemented; the ones that require rebuilding a --- `TxSkelOut` from an on-chain output (as well as credential-based address --- filtering and the exact credential conversion) are left as clearly marked --- `TODO`s to be refined. - -- | Interpret the `MockChainRead` effect by talking to a deployed node through -- a `Cardano.LocalNodeConnectInfo` (socket path and network id) provided via a --- `Reader`, running in a stack featuring @IO@ (via `Embed`). Failures are --- surfaced through the corresponding typed `Error` effects rather than being --- collapsed into generic failures. +-- `Reader`, running in a stack featuring @IO@ (via `Embed`). runMockChainReadNode :: forall effs a. ( Members @@ -445,6 +443,7 @@ runMockChainReadNode :: Error Cardano.AcquiringFailure, Error Cardano.PastHorizonException, Error P.Ledger.ToCardanoError, + Error MockChainError, Reader Cardano.LocalNodeConnectInfo ] effs @@ -452,64 +451,114 @@ runMockChainReadNode :: Sem (MockChainRead : effs) a -> Sem effs a runMockChainReadNode = interpret $ \case - -- Protocol parameters: a plain shelley-based-era query. - GetParams -> querySbe $ Cardano.queryProtocolParameters Cardano.ShelleyBasedEraConway - -- The current slot is read from the chain tip. + GetParams -> queryAndHandleErrors $ Cardano.queryProtocolParameters Cardano.ShelleyBasedEraConway + GetNetworkId -> asks Cardano.localNodeNetworkId CurrentSlot -> ask >>= fmap chainTipSlot . embed . Cardano.getLocalChainTip - -- Slot -> closed ms interval, computed from the era history and system start. + GetEraHistory -> queryAndHandleError Cardano.queryEraHistory + GetSystemStart -> queryAndHandleError Cardano.querySystemStart SlotToMSRange slot -> do - eraHistory <- execExpr Cardano.queryEraHistory >>= fromEither - systemStart <- execExpr Cardano.querySystemStart >>= fromEither + eraHistory <- queryAndHandleError Cardano.queryEraHistory + systemStart <- queryAndHandleError Cardano.querySystemStart (relStart, slotLen) <- fromEither $ Cardano.getProgress (toSlotNo slot) eraHistory let startUTC = Time.fromRelativeTime systemStart relStart - endUTC = addUTCTime (Time.getSlotLength slotLen) startUTC - -- TODO: refine the closed-interval boundary handling (the emulator returns - -- an inclusive ms interval; here we take [start, start + slotLength]). - return (utcToPOSIXTime startUTC, utcToPOSIXTime endUTC) - -- POSIXTime -> enclosing slot, via the era history interpreter. + endUTC = Time.getSlotLength slotLen `addUTCTime` startUTC + return (utcToPOSIXTime startUTC, utcToPOSIXTime endUTC - 1) GetEnclosingSlot t -> do - eraHistory <- execExpr Cardano.queryEraHistory >>= fromEither - systemStart <- execExpr Cardano.querySystemStart >>= fromEither - let relTime = Time.toRelativeTime systemStart (posixTimeToUTC t) + eraHistory <- queryAndHandleError Cardano.queryEraHistory + systemStart <- queryAndHandleError Cardano.querySystemStart + let relTime = Time.toRelativeTime systemStart $ posixTimeToUTC t fromSlotNo <$> fromEither (Cardano.getSlotForRelativeTime relTime eraHistory) - -- All UTxOs owned by a credential. - UtxosAt _cred -> do - -- TODO: filter node-side by address. A credential alone does not determine - -- an address (the staking part is unknown), and `QueryUTxOByAddress` takes - -- full addresses. For now we query the whole set and would filter - -- client-side by `Script.toCredential cred` once `txSkelOutFromApiTxOut` is - -- implemented. Querying the whole UTxO set is expensive: refine later. - utxo <- queryUtxos Cardano.QueryUTxOWhole - mapM convertUtxo (Map.toList (Cardano.unUTxO utxo)) - -- A single output, resolved by its reference. + AllUtxos -> queryUtxosAndHandleErrors Cardano.QueryUTxOWhole + UtxosAt (Script.toAddress -> addr) -> do + networkId <- asks Cardano.localNodeNetworkId + (Cardano.AddressInEra _ cAddr) <- fromEither $ P.Ledger.toCardanoAddressInEra networkId addr + queryUtxosAndHandleErrors $ Cardano.QueryUTxOByAddress $ Set.singleton $ Cardano.toAddressAny cAddr TxSkelOutByRef oRef -> do txIn <- fromEither $ P.Ledger.toCardanoTxIn oRef - utxo <- queryUtxos $ Cardano.QueryUTxOByTxIn $ Set.singleton txIn - case Map.elems (Cardano.unUTxO utxo) of - [txOut] -> txSkelOutFromApiTxOut txOut - -- TODO: decide how a missing UTxO should be signalled by the node backend. - _ -> error "runMockChainReadNode: TxSkelOutByRef on a missing UTxO" - -- The current reward accumulated by a credential's stake address. + utxo <- queryUtxosAndHandleErrors $ Cardano.QueryUTxOByTxIn $ Set.singleton txIn + case utxo of + [(_, txSkelOut)] -> return txSkelOut + -- This case is reduced to [] as there can never be more than one UTxO + -- with a given 'Api.TxOutRef'. + _ -> throw $ MCEUnknownOutRef oRef + -- The constitution query only exposes the guardrail script /hash/, never the + -- script bytes themselves. To recover the full script, we rely on the on-chain + -- convention (used on the public networks) that the guardrail script is posted + -- as a reference script at its own enterprise script address. We therefore + -- derive that address from the queried hash, list the UTxOs sitting there, and + -- return the reference script whose hash matches the constitution's. When no + -- such reference script is present (e.g. on a private network where nobody + -- posted it), we return 'Nothing'. + GetConstitutionScript -> do + Cardano.Constitution _ mScriptHash <- + queryAndHandleErrors $ Cardano.queryConstitution Cardano.ConwayEraOnwardsConway + case mScriptHash of + SNothing -> return Nothing + SJust (Cardano.ScriptHash -> scriptHash) -> do + networkId <- asks Cardano.localNodeNetworkId + utxo <- + queryUtxosAndHandleErrors $ + Cardano.QueryUTxOByAddress $ + Set.singleton $ + Cardano.AddressShelley $ + Cardano.makeShelleyAddress + networkId + (Cardano.PaymentCredentialByScript scriptHash) + Cardano.NoStakeAddress + return $ + listToMaybe $ + [ script + | (_, preview txSkelOutReferenceScriptAT -> Just script) <- utxo, + Script.toScriptHash script == Script.toScriptHash scriptHash + ] GetCurrentReward (Script.toCredential -> cred) -> do networkId <- asks Cardano.localNodeNetworkId - let stakeCred = toCardanoStakeCredential cred - stakeAddr = Cardano.makeStakeAddress networkId stakeCred - (rewards, _) <- querySbe $ Cardano.queryStakeAddresses Cardano.ShelleyBasedEraConway (Set.singleton stakeCred) networkId - return $ Api.Lovelace . Cardano.unCoin <$> Map.lookup stakeAddr rewards + stakeCred <- toStakeCredential cred + (rewards, _) <- + queryAndHandleErrors $ + Cardano.queryStakeAddresses + Cardano.ShelleyBasedEraConway + (Set.singleton (Cardano.fromShelleyStakeCredential stakeCred)) + networkId + return $ Api.Lovelace . Cardano.unCoin <$> Map.lookup (Cardano.StakeAddress (Cardano.toShelleyNetwork networkId) stakeCred) rewards where - execExpr expr = ask >>= \conn -> embed (Cardano.executeLocalStateQueryExpr conn Cardano.VolatileTip expr) >>= fromEither - querySbe expr = execExpr expr >>= fromEither >>= fromEither - queryUtxos flt = querySbe (Cardano.queryUtxo Cardano.ShelleyBasedEraConway flt) + -- Fetches the local node info, embeds a query in IO and handles errors + query q = do + conn <- ask + response <- embed $ Cardano.executeLocalStateQueryExpr conn Cardano.VolatileTip q + fromEither response + -- Handles one more layer of errors from the response of a query + queryAndHandleError q = query q >>= fromEither + -- Handles a second layer of error from the response of a query + queryAndHandleErrors q = queryAndHandleError q >>= fromEither + -- Queries the Utxos present on-chain, handling the errors, and returns the + -- query result in terms of @Utxos@ + queryUtxosAndHandleErrors utxoFilter = do + utxo <- queryAndHandleErrors $ Cardano.queryUtxo Cardano.ShelleyBasedEraConway utxoFilter + return $ bimap P.Ledger.fromCardanoTxIn convertUtxo <$> Map.toList (Cardano.unUTxO utxo) + -- Retrieves the Plutus slot number from a chain tip chainTipSlot Cardano.ChainTipAtGenesis = P.Ledger.Slot 0 chainTipSlot (Cardano.ChainTip slotNo _ _) = fromSlotNo slotNo + -- Converts a Plutus slot to a Cardano slot toSlotNo = Cardano.SlotNo . fromInteger . P.Ledger.getSlot + -- Converts a Cardano slot to a Plutus slot fromSlotNo (Cardano.SlotNo w) = P.Ledger.Slot (toInteger w) - posixTimeToUTC t = posixSecondsToUTCTime (fromRational (toRational (Api.getPOSIXTime t) / 1000)) - utcToPOSIXTime u = Api.POSIXTime (round (1000 * utcTimeToPOSIXSeconds u)) - convertUtxo (txIn, txOut) = (P.Ledger.fromCardanoTxIn txIn,) <$> txSkelOutFromApiTxOut txOut - -- TODO: reconstruct a `TxSkelOut` from an on-chain output (owner and staking - -- credentials from the address, value, datum, reference script). - txSkelOutFromApiTxOut _ = error "txSkelOutFromApiTxOut: not implemented yet" - -- TODO: convert a Plutus credential into a `Cardano.StakeCredential` - -- (`toStakeCredential`, already imported, may be reusable here). - toCardanoStakeCredential _ = error "toCardanoStakeCredential: not implemented yet" + -- Converts a POSIX time to a UTC time + posixTimeToUTC = posixSecondsToUTCTime . fromRational . (/ 1000) . toRational . Api.getPOSIXTime + -- Converts a UTC time to a POSIX time + utcToPOSIXTime = Api.POSIXTime . round . (1000 *) . utcTimeToPOSIXSeconds + convertUtxo :: Cardano.TxOut Cardano.CtxUTxO Cardano.ConwayEra -> TxSkelOut + convertUtxo (Cardano.TxOut (P.Ledger.toPlutusAddress -> (Api.Address cred stCred)) val dat refScript) = + TxSkelOut + (review userCredentialI cred) + stCred + ( dat & \case + Cardano.TxOutDatumNone -> NoTxSkelOutDatum + Cardano.TxOutDatumHash _ hash -> + SomeTxSkelOutDatumHash $ Api.DatumHash $ Api.toBuiltin $ Cardano.serialiseToRawBytes hash + Cardano.TxOutDatumInline _ datum -> + SomeTxSkelOutDatum (P.Ledger.fromCardanoScriptData datum) Inline + ) + (P.Ledger.fromCardanoValue $ P.Ledger.fromCardanoTxOutValue val) + False + (P.Ledger.fromCardanoReferenceScript refScript) diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index 0cbdd3c7d..26a7bc6ee 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -109,11 +109,11 @@ runMockChainWrite = interpret $ \case cScript ForceOutputs outputs -> do -- We retrieve the protocol parameters - params <- getParams + networkId <- getNetworkId -- The emulator takes for granted transactions with a single pseudo input, -- which we build to force transaction validation let input = - ( Cardano.genesisUTxOPseudoTxIn (Emulator.pNetworkId params) $ + ( Cardano.genesisUTxOPseudoTxIn networkId $ Cardano.GenesisUTxOKeyHash $ Cardano.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194", Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/MockChain/Runtime/Error.hs index 03f2119b8..e71cd5a59 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/MockChain/Runtime/Error.hs @@ -41,7 +41,7 @@ data BalancingError -- | Errors that can be produced by the blockchain data MockChainError = -- | Validation errors, either in Phase 1 or Phase 2 - MCEValidationError P.Ledger.ValidationPhase P.Ledger.ValidationError + MCEValidationError [(P.Ledger.ValidationPhase, P.Ledger.ValidationError)] | -- | Balancing errors MCEBalancingError BalancingError | -- | Translating a skeleton element to its Cardano counterpart failed diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index 09e82d43a..c359cf599 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/MockChain/UtxoSearch.hs @@ -115,7 +115,7 @@ getTxOutRefsAndOutputs = fmap (fmap (\(oRef, HCons output _) -> (oRef, output))) -- | Searches for utxos at a given address with a given filter utxosAtSearch :: - (Member MockChainRead effs, Script.ToCredential pkh) => + (Member MockChainRead effs, Script.ToAddress pkh) => pkh -> (UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els diff --git a/src/Cooked/Skeleton/Datum.hs b/src/Cooked/Skeleton/Datum.hs index f53d58fc3..0a1fbd4b2 100644 --- a/src/Cooked/Skeleton/Datum.hs +++ b/src/Cooked/Skeleton/Datum.hs @@ -18,6 +18,7 @@ module Cooked.Skeleton.Datum txSkelOutDatumDatumAF, txSkelOutDatumDatumHashAF, txSkelOutDatumOutputDatumG, + txSkelOutDatumOutputDatumI, ) where @@ -169,3 +170,17 @@ instance Script.ToOutputDatum TxSkelOutDatum where toOutputDatum (SomeTxSkelOutDatum datum Inline) = Api.OutputDatum $ Api.Datum $ Api.toBuiltinData datum toOutputDatum (SomeTxSkelOutDatum datum _) = Api.OutputDatumHash $ Script.datumHash $ Api.Datum $ Api.toBuiltinData datum toOutputDatum (SomeTxSkelOutDatumHash hash) = Api.OutputDatumHash hash + +-- | An isomorphism betwean our 'TxSkelOutDatum' and Plutus +-- 'Api.OutputDatum'. The existence of this function does not mean that both +-- share the same expressiveness. In only means that there exists a sensible way +-- to convert one into the other, and vice versa. +txSkelOutDatumOutputDatumI :: Iso' TxSkelOutDatum Api.OutputDatum +txSkelOutDatumOutputDatumI = + iso + Script.toOutputDatum + ( \case + Api.OutputDatum (Api.Datum bData) -> SomeTxSkelOutDatum bData Inline + Api.NoOutputDatum -> NoTxSkelOutDatum + Api.OutputDatumHash dHash -> SomeTxSkelOutDatumHash dHash + ) diff --git a/src/Cooked/Skeleton/Proposal.hs b/src/Cooked/Skeleton/Proposal.hs index 90f8a0edb..d32d7ee77 100644 --- a/src/Cooked/Skeleton/Proposal.hs +++ b/src/Cooked/Skeleton/Proposal.hs @@ -223,8 +223,8 @@ makeLensesFor [("txSkelProposalAnchor", "txSkelProposalAnchorL")] ''TxSkelPropos 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. +-- | Sets the constitution script with an empty redeemer. This will not tamper +-- with an existing constitution script and redeemer. fillConstitution :: (ToVScript script, Typeable script) => script -> TxSkelProposal -> TxSkelProposal fillConstitution constitution = over diff --git a/src/Cooked/Skeleton/User.hs b/src/Cooked/Skeleton/User.hs index 3e430f432..1b8ce74dc 100644 --- a/src/Cooked/Skeleton/User.hs +++ b/src/Cooked/Skeleton/User.hs @@ -19,6 +19,7 @@ module Cooked.Skeleton.User -- * Optics userHashG, userCredentialG, + userCredentialI, userRedeemerAT, userVScriptAT, userScriptHashAF, @@ -219,6 +220,16 @@ userEitherPubKeyP = userCredentialG :: Getter (User kind mode) Api.Credential userCredentialG = to Script.toCredential +-- | An isomorphism between an 'Api.Credential' and an allocation user +userCredentialI :: Iso' (User IsEither Allocation) Api.Credential +userCredentialI = + iso + (view userCredentialG) + ( \case + Api.ScriptCredential sHash -> UserScriptHash sHash + Api.PubKeyCredential pkh -> UserPubKey pkh + ) + -- | Focuses on the optional 'TxSkelRedeemer' of a 'User' userRedeemerAT :: AffineTraversal' (User kind mode) TxSkelRedeemer userRedeemerAT = From 388a694e326abbfc62ee5aada6206c007b7d3a1e Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Aug 2026 10:13:47 +0200 Subject: [PATCH 06/18] library compiles --- .../MockChain/Automation/GenerateTx/Body.hs | 5 +- src/Cooked/MockChain/Effect/Write.hs | 53 ++++++++----------- src/Cooked/MockChain/Run/Instances.hs | 6 +-- src/Cooked/MockChain/Runtime/Error.hs | 2 +- src/Cooked/MockChain/Testing.hs | 10 ++-- src/Cooked/Pretty/MockChain.hs | 4 +- src/Cooked/Pretty/Skeleton.hs | 8 +-- src/Cooked/Skeleton/Option.hs | 51 +++--------------- 8 files changed, 41 insertions(+), 98 deletions(-) diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs index d4c10e870..d5759718b 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs @@ -135,8 +135,7 @@ txSkelToTxBody txSkel fee mCollaterals = do ) Left err -> ( success, - ( P.Ledger.Phase2, - case err of + ( case err of Alonzo.ValidationFailure _ (Api.CekError e) logs _ -> P.Ledger.ScriptFailure (Api.EvaluationError logs ("CekEvaluationFailure: " ++ show e)) e -> P.Ledger.CardanoLedgerValidationError $ Text.pack $ show e ) @@ -156,7 +155,7 @@ txSkelToTxBody txSkel fee mCollaterals = do -- the final body from it Right txBodyContent -> txBodyContentToTxBody txBodyContent -- Some validation failures detected, and they should be handled - l | not $ txSkelOptDeferPhase2FailuresDuringBalancing $ txSkelOpts txSkel -> throw $ MCEValidationError l + l | not $ txSkelOptDeferPhase2FailuresDuringBalancing $ txSkelOpts txSkel -> throw $ MCEValidationError P.Ledger.Phase2 l -- Some validation failures detected, which should be deferred. We ignore -- them and return the current body without assigning execution units. _ -> return txBody' diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index 26a7bc6ee..df4b000f3 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -109,15 +109,9 @@ runMockChainWrite = interpret $ \case cScript ForceOutputs outputs -> do -- We retrieve the protocol parameters + params <- getParams + -- We retrieve the network id networkId <- getNetworkId - -- The emulator takes for granted transactions with a single pseudo input, - -- which we build to force transaction validation - let input = - ( Cardano.genesisUTxOPseudoTxIn networkId $ - Cardano.GenesisUTxOKeyHash $ - Cardano.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194", - Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending - ) -- We adjust the outputs for the minimal required ADA if needed outputsMinAda <- mapM toTxSkelOutWithMinAda outputs -- We transform these outputs to Cardano outputs @@ -125,15 +119,21 @@ runMockChainWrite = interpret $ \case -- We create our transaction body, which only consists of the dummy input -- and the outputs to force, and make a transaction out of it. cardanoTx <- - P.Ledger.CardanoEmulatorEraTx . txSignatoriesAndBodyToCardanoTx [] - <$> fromEither - ( Emulator.createTransactionBody params $ - P.Ledger.CardanoBuildTx - ( P.Ledger.emptyTxBodyContent - { Cardano.txOuts = outputs', - Cardano.txIns = [input] - } - ) + P.Ledger.CardanoEmulatorEraTx . (`Cardano.Tx` []) + <$> txBodyContentToTxBody + ( P.Ledger.emptyTxBodyContent + { Cardano.txOuts = outputs', + -- The emulator takes for granted transactions with a single pseudo input, + -- which we build to force transaction validation + Cardano.txIns = + [ ( Cardano.genesisUTxOPseudoTxIn networkId $ + Cardano.GenesisUTxOKeyHash $ + Cardano.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194", + Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending + ) + ], + Cardano.txProtocolParams = Cardano.BuildTxWith . Just . Cardano.LedgerProtocolParameters $ params + } ) -- We need to adjust our internal state to account for the forced -- transaction. We begin by computing the new map of outputs. @@ -158,17 +158,11 @@ runMockChainWrite = interpret $ \case -- Finally, we return the created utxos return $ Map.toList (fst <$> outputsMap) ValidateTxSkel skel -> fmap snd $ runTweak skel $ do + params <- gets mcstParams -- We retrieve the current skeleton options TxSkelOpts {..} <- viewTweak txSkelOptsL -- We log the submission of the new skeleton viewTweak simple >>= logEvent . MCLogSubmittedTxSkel - -- We retrieve the current parameters - oldParams <- getParams - -- We compute the optionally modified parameters - let newParams = txSkelOptModParams oldParams - -- We change the parameters for the duration of the validation process - modify $ set mcstParamsL newParams - modify $ over mcstLedgerStateL $ Emulator.updateStateParams newParams -- We ensure that the outputs have the required minimal amount of ada, when -- requested in the skeleton options autoFillMinAda @@ -195,9 +189,9 @@ runMockChainWrite = interpret $ \case -- based on the validation result, and throw an error if this fails. If at -- some point we want to allows mockchain runs with validation errors, the -- caller will need to catch those errors and do something with them. - newOutputs <- case Emulator.validateCardanoTx newParams eLedgerState cardanoTx of + newOutputs <- case Emulator.validateCardanoTx params eLedgerState cardanoTx of -- In case of a phase 1 error, we give back the same index - (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 err + (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 [err] (newELedgerState, P.Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do -- We update the emulated ledger state modify' (set mcstLedgerStateL newELedgerState) @@ -209,7 +203,7 @@ runMockChainWrite = interpret $ \case (Just retColOutput, [(txIn, _)]) -> modify' $ addOutput (P.Ledger.fromCardanoTxIn txIn) retColOutput _ -> fail "Unreachable case when processing return collaterals, please report a bug at https://github.com/tweag/cooked-validators/issues" -- We throw a mockchain error - throw $ MCEValidationError P.Ledger.Phase2 err + throw $ MCEValidationError P.Ledger.Phase2 [err] -- In case of success, we update the index with all inputs and outputs -- contained in the transaction (newELedgerState, P.Ledger.Success {}) -> do @@ -231,11 +225,6 @@ runMockChainWrite = interpret $ \case (_, P.Ledger.FailPhase2 {}) | Nothing <- mCollaterals -> fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" - -- We apply a change of slot when requested in the options - when txSkelOptAutoSlotIncrease $ modify' (over mcstLedgerStateL Emulator.nextSlot) - -- We return the parameters to their original state - modify $ set mcstParamsL oldParams - modify $ over mcstLedgerStateL $ Emulator.updateStateParams oldParams -- We log the validated transaction logEvent $ MCLogNewTx (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) -- We return the validated transaction diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index 2fad07196..25c2648cd 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -88,7 +88,7 @@ instance RunnableMockChain DirectEffs where . runToCardanoErrorInMockChainError . runFailInMockChainError . runMockChainMisc fromAlias fromNote fromAssert - . runMockChainRead + . runMockChainReadEmul . runMockChainWrite . insertAt @4 @[ Error P.Ledger.ToCardanoError, @@ -145,7 +145,7 @@ instance RunnableMockChain FullEffs where . runError . runToCardanoErrorInMockChainError . runFailInMockChainError - . runMockChainRead + . runMockChainReadEmul . runMockChainMisc fromAlias fromNote fromAssert . evalState [] . runModifyLocally @@ -197,7 +197,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runError . runToCardanoErrorInMockChainError . runFailInMockChainError - . runMockChainRead + . runMockChainReadEmul . runMockChainMisc fromAlias fromNote fromAssert . runInterpretAlone . evalState [] diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/MockChain/Runtime/Error.hs index e71cd5a59..032ec159f 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/MockChain/Runtime/Error.hs @@ -41,7 +41,7 @@ data BalancingError -- | Errors that can be produced by the blockchain data MockChainError = -- | Validation errors, either in Phase 1 or Phase 2 - MCEValidationError [(P.Ledger.ValidationPhase, P.Ledger.ValidationError)] + MCEValidationError P.Ledger.ValidationPhase [P.Ledger.ValidationError] | -- | Balancing errors MCEBalancingError BalancingError | -- | Translating a skeleton element to its Cardano counterpart failed diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index 4fe651bc8..c1ac78abc 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -580,9 +580,8 @@ isPhase1FailureWithMsg :: (IsProp prop) => String -> FailureProp prop -isPhase1FailureWithMsg s _ _ (MCEValidationError P.Ledger.Phase1 (P.Ledger.CardanoLedgerValidationError text)) _ - | s `isInfixOf` T.unpack text = - testSuccess +isPhase1FailureWithMsg s _ _ (MCEValidationError P.Ledger.Phase1 l) _ + | not $ null [text | P.Ledger.CardanoLedgerValidationError (T.unpack -> text) <- l, s `isInfixOf` text] = testSuccess isPhase1FailureWithMsg _ pcOpts _ e _ = testFailureMsg $ "Expected phase 1 evaluation failure with constrained messages, got: " @@ -593,9 +592,8 @@ isPhase2FailureWithMsg :: (IsProp prop) => String -> FailureProp prop -isPhase2FailureWithMsg s _ _ (MCEValidationError P.Ledger.Phase2 (P.Ledger.ScriptFailure (Api.EvaluationError texts _))) _ - | any (isInfixOf s . T.unpack) texts = - testSuccess +isPhase2FailureWithMsg s _ _ (MCEValidationError P.Ledger.Phase2 l) _ + | not $ null [text | P.Ledger.ScriptFailure (Api.EvaluationError texts _) <- l, (T.unpack -> text) <- texts, s `isInfixOf` text] = testSuccess isPhase2FailureWithMsg _ pcOpts _ e _ = testFailureMsg $ "Expected phase 2 evaluation failure with constrained messages, got: " diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index 7a946bd9b..597b30878 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -86,8 +86,8 @@ instance PrettyCooked BalancingError where ] instance PrettyCooked MockChainError where - prettyCookedOpt opts (MCEValidationError plutusPhase plutusError) = - PP.vsep ["Validation error " <+> prettyCookedOpt opts plutusPhase, PP.indent 2 (prettyCookedOpt opts plutusError)] + prettyCookedOpt opts (MCEValidationError plutusPhase plutusErrors) = + prettyItemize opts ("Validation errors (" <+> prettyCookedOpt opts plutusPhase <+> ")") "-" plutusErrors prettyCookedOpt opts (MCEBalancingError err) = prettyCookedOpt opts err prettyCookedOpt _ (MCEToCardanoError cardanoError) = "Transaction generation error:" <+> PP.pretty cardanoError diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index 2e50ff648..68edf6ad9 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/src/Cooked/Pretty/Skeleton.hs @@ -287,19 +287,16 @@ instance PrettyCookedList TxSkelOpts where prettyCookedOptListMaybe opts ( TxSkelOpts - txSkelOptAutoSlotIncrease _ txSkelOptBalancingPolicy txSkelOptFeePolicy txSkelOptBalanceOutputPolicy txSkelOptBalancingUtxos - _ txSkelOptCollateralUtxos txSkelOptDeferFailures txSkelOptMaxNbOfBalancingUtxos ) = - [ prettyIfNot True prettyAutoSlotIncrease txSkelOptAutoSlotIncrease, - prettyIfNot def prettyBalanceOutputPolicy txSkelOptBalanceOutputPolicy, + [ prettyIfNot def prettyBalanceOutputPolicy txSkelOptBalanceOutputPolicy, prettyIfNot def prettyBalanceFeePolicy txSkelOptFeePolicy, prettyIfNot def prettyBalancingPolicy txSkelOptBalancingPolicy, prettyIfNot def prettyBalancingUtxos txSkelOptBalancingUtxos, @@ -312,9 +309,6 @@ instance PrettyCookedList TxSkelOpts where prettyIfNot defaultValue f x | x == defaultValue && not (pcOptPrintDefaultTxSkelOpts opts) = Nothing | otherwise = Just $ f x - prettyAutoSlotIncrease :: Bool -> DocCooked - prettyAutoSlotIncrease True = "Automatic slot increase" - prettyAutoSlotIncrease False = "No automatic slot increase" prettyBalanceOutputPolicy :: BalanceOutputPolicy -> DocCooked prettyBalanceOutputPolicy AdjustExistingOutput = "Balance policy: Adjust existing outputs" prettyBalanceOutputPolicy DontAdjustExistingOutput = "Balance policy: Don't adjust existing outputs" diff --git a/src/Cooked/Skeleton/Option.hs b/src/Cooked/Skeleton/Option.hs index 05d961e69..519181cd7 100644 --- a/src/Cooked/Skeleton/Option.hs +++ b/src/Cooked/Skeleton/Option.hs @@ -13,24 +13,20 @@ module Cooked.Skeleton.Option -- * Optics txSkelOptModTxL, - txSkelOptAutoSlotIncreaseL, txSkelOptBalancingPolicyL, txSkelOptBalanceOutputPolicyL, txSkelOptFeePolicyL, txSkelOptBalancingUtxosL, - txSkelOptModParamsL, txSkelOptCollateralUtxosL, txSkelOptDeferPhase2FailuresDuringBalancingL, txSkelOptMaxNbOfBalancingUtxosL, -- * Utilities txSkelOptAddModTx, - txSkelOptAddModParams, ) where import Cardano.Api qualified as Cardano -import Cardano.Node.Emulator qualified as Emulator import Data.Default import Data.Set (Set) import Data.Typeable @@ -133,14 +129,7 @@ instance Default CollateralUtxos where -- | Set of options to modify the behavior of generating and validating some -- transaction. data TxSkelOpts = TxSkelOpts - { -- | Whether to increase the slot counter automatically on transaction - -- submission. This is useful for modelling transactions that could be - -- submitted in parallel in reality, so there should be no explicit ordering - -- of what comes first. - -- - -- Default is @True@. - txSkelOptAutoSlotIncrease :: Bool, - -- | Applies an arbitrary modification to a transaction after it has been + { -- | Applies an arbitrary modification to a transaction after it has been -- potentially adjusted and balanced. The name of this option contains -- /unsafe/ to draw attention to the fact that modifying a transaction at -- that stage might make it invalid. Still, this offers a hook for being @@ -178,19 +167,6 @@ data TxSkelOpts = TxSkelOpts -- -- Default is 'BalancingUtxosFromBalancingUser'. txSkelOptBalancingUtxos :: BalancingUtxos, - -- | Apply an arbitrary modification to the protocol parameters that are - -- used to balance and submit the transaction. This is obviously a very - -- unsafe thing to do if you want to preserve compatibility with the actual - -- chain. It is useful mainly for testing purposes, when you might want to - -- use extremely big transactions or transactions that exhaust the maximum - -- execution budget. Such a thing could be accomplished with - -- - -- > txSkelOptModParams = Just $ ModParams increaseTransactionLimits - -- - -- for example. - -- - -- Default is 'Nothing'. - txSkelOptModParams :: Emulator.Params -> Emulator.Params, -- | Which utxos to use as collaterals. They can be given manually, or -- computed automatically from a given, or the balancing, user. -- @@ -235,10 +211,9 @@ data TxSkelOpts = TxSkelOpts -- | 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 deferFailures maxNbBalUtxos) - == (TxSkelOpts slotIncrease' _ balancingPol' feePol' balOutputPol' balUtxos' _ colUtxos' deferFailures' maxNbBalUtxos') = - slotIncrease == slotIncrease' - && balancingPol == balancingPol' + (TxSkelOpts _ balancingPol feePol balOutputPol balUtxos colUtxos deferFailures maxNbBalUtxos) + == (TxSkelOpts _ balancingPol' feePol' balOutputPol' balUtxos' colUtxos' deferFailures' maxNbBalUtxos') = + balancingPol == balancingPol' && feePol == feePol' && balOutputPol == balOutputPol' && balUtxos == balUtxos' @@ -249,11 +224,8 @@ instance Eq TxSkelOpts where -- | 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 deferFailures maxNbBalUtxos) = - show [show slotIncrease, show balancingPol, show feePol, show balOutputPol, show balUtxos, show colUtxos, show deferFailures, show maxNbBalUtxos] - --- | Focuses on the automatic slot increase option of a 'TxSkelOpts' -makeLensesFor [("txSkelOptAutoSlotIncrease", "txSkelOptAutoSlotIncreaseL")] ''TxSkelOpts + show (TxSkelOpts _ balancingPol feePol balOutputPol balUtxos colUtxos deferFailures maxNbBalUtxos) = + show [show balancingPol, show feePol, show balOutputPol, show balUtxos, show colUtxos, show deferFailures, show maxNbBalUtxos] -- | Focuses on the Cardano transaction modifications option of a 'TxSkelOpts' makeLensesFor [("txSkelOptModTx", "txSkelOptModTxL")] ''TxSkelOpts @@ -270,9 +242,6 @@ makeLensesFor [("txSkelOptBalanceOutputPolicy", "txSkelOptBalanceOutputPolicyL") -- | Focuses on the balancing utxos option of a 'TxSkelOpts' makeLensesFor [("txSkelOptBalancingUtxos", "txSkelOptBalancingUtxosL")] ''TxSkelOpts --- | Focuses on the changes to protocol parameters option of a 'TxSkelOpts' -makeLensesFor [("txSkelOptModParams", "txSkelOptModParamsL")] ''TxSkelOpts - -- | Focuses on the collateral utxos option of a 'TxSkelOpts' makeLensesFor [("txSkelOptCollateralUtxos", "txSkelOptCollateralUtxosL")] ''TxSkelOpts @@ -285,13 +254,11 @@ makeLensesFor [("txSkelOptMaxNbOfBalancingUtxos", "txSkelOptMaxNbOfBalancingUtxo instance Default TxSkelOpts where def = TxSkelOpts - { txSkelOptAutoSlotIncrease = True, - txSkelOptModTx = id, + { txSkelOptModTx = id, txSkelOptBalancingPolicy = def, txSkelOptBalanceOutputPolicy = def, txSkelOptFeePolicy = def, txSkelOptBalancingUtxos = def, - txSkelOptModParams = id, txSkelOptCollateralUtxos = def, txSkelOptDeferPhase2FailuresDuringBalancing = False, txSkelOptMaxNbOfBalancingUtxos = Nothing @@ -300,7 +267,3 @@ instance Default TxSkelOpts where -- | Appends a transaction modification to the given 'TxSkelOpts' txSkelOptAddModTx :: (Cardano.Tx Cardano.ConwayEra -> Cardano.Tx Cardano.ConwayEra) -> TxSkelOpts -> TxSkelOpts txSkelOptAddModTx modTx = over txSkelOptModTxL (modTx .) - --- | Appends a parameters modification to the given 'TxSkelOpts' -txSkelOptAddModParams :: (Emulator.Params -> Emulator.Params) -> TxSkelOpts -> TxSkelOpts -txSkelOptAddModParams modParams = over txSkelOptModParamsL (modParams .) From d15aaacc883aff5eeebbbb71efded47dbc4800a9 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Aug 2026 12:47:32 +0200 Subject: [PATCH 07/18] updating tests, everything works --- tests/Spec/Balancing.hs | 6 +++--- tests/Spec/Slot.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index 0457f4740..6e9480292 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -222,15 +222,15 @@ failsAtBalancing (MCEBalancingError (NotEnoughFundForExtraMinAda {})) = testBool failsAtBalancing _ = testBool False failsWithTooLittleFee :: MockChainError -> Assertion -failsWithTooLittleFee (MCEValidationError P.Ledger.Phase1 (P.Ledger.CardanoLedgerValidationError text)) = testBool $ isInfixOf "FeeTooSmallUTxO" text +failsWithTooLittleFee (MCEValidationError P.Ledger.Phase1 [P.Ledger.CardanoLedgerValidationError text]) = testBool $ isInfixOf "FeeTooSmallUTxO" text failsWithTooLittleFee _ = testBool False failsWithValueNotConserved :: MockChainError -> Assertion -failsWithValueNotConserved (MCEValidationError P.Ledger.Phase1 (P.Ledger.CardanoLedgerValidationError text)) = testBool $ isInfixOf "ValueNotConserved" text +failsWithValueNotConserved (MCEValidationError P.Ledger.Phase1 [P.Ledger.CardanoLedgerValidationError text]) = testBool $ isInfixOf "ValueNotConserved" text failsWithValueNotConserved _ = testBool False failsWithEmptyTxIns :: MockChainError -> Assertion -failsWithEmptyTxIns (MCEValidationError P.Ledger.Phase1 (P.Ledger.CardanoLedgerValidationError text)) = testBool $ isInfixOf "InputSetEmptyUTxO" text +failsWithEmptyTxIns (MCEValidationError P.Ledger.Phase1 [P.Ledger.CardanoLedgerValidationError text]) = testBool $ isInfixOf "InputSetEmptyUTxO" text failsWithEmptyTxIns _ = testBool False failsAtCollateralsWith :: Integer -> MockChainError -> Assertion diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index f16b38306..41869ffd5 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -30,7 +30,7 @@ runSlot = . runToCardanoErrorInMockChainError . runFailInMockChainError . evalState def - . runMockChainRead + . runMockChainReadEmul tests :: TestTree tests = From 05185294bebd26e481f3b805e93262988cb56525 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Aug 2026 16:47:14 +0200 Subject: [PATCH 08/18] restructuring read effects into Conf and Chain --- cooked-validators.cabal | 3 +- src/Cooked/MockChain.hs | 3 +- .../Automation/AutoFilling/Constitution.hs | 4 +- .../Automation/AutoFilling/MinAda.hs | 9 +- .../AutoFilling/ReferenceScripts.hs | 6 +- .../Automation/AutoFilling/Withdrawals.hs | 4 +- src/Cooked/MockChain/Automation/Balancing.hs | 17 +- .../MockChain/Automation/GenerateTx/Body.hs | 11 +- .../Automation/GenerateTx/Certificate.hs | 13 +- .../Automation/GenerateTx/Collateral.hs | 5 +- .../MockChain/Automation/GenerateTx/Input.hs | 4 +- .../MockChain/Automation/GenerateTx/Mint.hs | 4 +- .../MockChain/Automation/GenerateTx/Output.hs | 5 +- .../Automation/GenerateTx/Proposal.hs | 7 +- .../Automation/GenerateTx/ReferenceInputs.hs | 4 +- .../Automation/GenerateTx/Withdrawals.hs | 5 +- .../Automation/GenerateTx/Witness.hs | 6 +- .../Effect/{Read.hs => Read/Chain.hs} | 360 ++++++------------ src/Cooked/MockChain/Effect/Read/Conf.hs | 212 +++++++++++ src/Cooked/MockChain/Effect/Write.hs | 18 +- src/Cooked/MockChain/Run/Instances.hs | 64 ++-- src/Cooked/MockChain/UtxoSearch.hs | 10 +- tests/Spec/Slot.hs | 6 +- 23 files changed, 446 insertions(+), 334 deletions(-) rename src/Cooked/MockChain/Effect/{Read.hs => Read/Chain.hs} (65%) create mode 100644 src/Cooked/MockChain/Effect/Read/Conf.hs diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 5fbb243ee..0bf228626 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -44,7 +44,8 @@ library Cooked.MockChain.Common Cooked.MockChain.Effect.Log Cooked.MockChain.Effect.Misc - Cooked.MockChain.Effect.Read + Cooked.MockChain.Effect.Read.Chain + Cooked.MockChain.Effect.Read.Conf Cooked.MockChain.Effect.Write Cooked.MockChain.Run.Instances Cooked.MockChain.Run.Runnable diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index 7dff3ba5e..3d7f32ecc 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -5,7 +5,8 @@ module Cooked.MockChain (module X) where import Cooked.MockChain.Automation.Balancing as X import Cooked.MockChain.Common as X import Cooked.MockChain.Effect.Misc as X -import Cooked.MockChain.Effect.Read as X +import Cooked.MockChain.Effect.Read.Chain as X +import Cooked.MockChain.Effect.Read.Conf as X import Cooked.MockChain.Effect.Write as X import Cooked.MockChain.Run.Instances as X import Cooked.MockChain.Run.Runnable as X diff --git a/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs b/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs index 3d0e437c5..53f17fd65 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs +++ b/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs @@ -8,7 +8,7 @@ where import Control.Monad import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -23,7 +23,7 @@ import Polysemy -- existing specified script in such proposals. Logs an event when the -- constitution script has been successfully auto-filled. autoFillConstitution :: - (Members '[MockChainRead, Tweak, MockChainLog] effs) => + (Members '[MockChainReadChain, Tweak, MockChainLog] effs) => Sem effs () autoFillConstitution = do currentConstitution <- getConstitutionScript diff --git a/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs b/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs index b4547f59e..f4e712654 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs +++ b/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs @@ -13,7 +13,8 @@ import Cardano.Ledger.Shelley.Core qualified as Shelley import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Output import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -27,7 +28,7 @@ import Polysemy.Error -- | Compute the required minimal ADA for a given output getTxSkelOutMinAda :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => TxSkelOut -> Sem effs Integer getTxSkelOutMinAda txSkelOut = do @@ -44,7 +45,7 @@ getTxSkelOutMinAda txSkelOut = do -- will increase the size of the UTXO which in turn might need more ADA. toTxSkelOutWithMinAda :: forall effs. - (Members '[MockChainRead, MockChainLog, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, MockChainLog, Error P.Ledger.ToCardanoError] effs) => TxSkelOut -> Sem effs TxSkelOut -- The auto adjustment is disabled so nothing is done here @@ -71,6 +72,6 @@ toTxSkelOutWithMinAda txSkelOut = do -- their ada value when requested by the user and required by the protocol -- parameters. Logs an event whenever such a change occurs. autoFillMinAda :: - (Members '[Tweak, MockChainRead, MockChainLog, Error P.Ledger.ToCardanoError] effs) => + (Members '[Tweak, MockChainReadChain, MockChainReadConf, MockChainLog, Error P.Ledger.ToCardanoError] effs) => Sem effs () autoFillMinAda = traverseTweak (txSkelOutputsL % traversed) toTxSkelOutWithMinAda diff --git a/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs b/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs index 066792b4e..719f8a64b 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs +++ b/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs @@ -9,7 +9,7 @@ where import Control.Monad import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.UtxoSearch import Cooked.Skeleton import Cooked.Tweak.Common @@ -28,7 +28,7 @@ import Polysemy -- 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. updateRedeemedScript :: - (Members '[MockChainLog, MockChainRead] effs) => + (Members '[MockChainLog, MockChainReadChain] effs) => [Api.TxOutRef] -> User IsScript Redemption -> Sem effs (User IsScript Redemption) @@ -60,7 +60,7 @@ updateRedeemedScript _ rs = return rs -- allowed and one has not already been set. Logs an event whenever such an -- addition occurs. autoFillReferenceScripts :: - (Members '[Tweak, MockChainRead, MockChainLog] effs) => + (Members '[Tweak, MockChainReadChain, MockChainLog] effs) => Sem effs () autoFillReferenceScripts = do inputsKeys <- viewTweak $ txSkelInputsL % to Map.keys diff --git a/src/Cooked/MockChain/Automation/AutoFilling/Withdrawals.hs b/src/Cooked/MockChain/Automation/AutoFilling/Withdrawals.hs index 12c2271fe..8e73398d1 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/Withdrawals.hs +++ b/src/Cooked/MockChain/Automation/AutoFilling/Withdrawals.hs @@ -6,7 +6,7 @@ module Cooked.MockChain.Automation.AutoFilling.Withdrawals where import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -21,7 +21,7 @@ import Polysemy -- tamper with an existing specified amount in such withdrawals. Logs an event -- when an amount has been successfully auto-filled. autoFillWithdrawalAmounts :: - (Members '[MockChainRead, Tweak, MockChainLog] effs) => + (Members '[MockChainReadChain, Tweak, MockChainLog] effs) => Sem effs () autoFillWithdrawalAmounts = do traverseTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI % traversed) $ \withdrawal -> do diff --git a/src/Cooked/MockChain/Automation/Balancing.hs b/src/Cooked/MockChain/Automation/Balancing.hs index 8be53c93f..f9a179219 100644 --- a/src/Cooked/MockChain/Automation/Balancing.hs +++ b/src/Cooked/MockChain/Automation/Balancing.hs @@ -20,7 +20,8 @@ import Cooked.MockChain.Automation.GenerateTx.Body import Cooked.MockChain.Automation.GenerateTx.Output import Cooked.MockChain.Common import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.UtxoSearch import Cooked.Skeleton @@ -66,7 +67,7 @@ data ExtendedTxSkel = ExtendedTxSkel -- skeleton control whether it should be balanced, and how to compute its -- associated elements. balanceTxSkel :: - (Members '[MockChainRead, MockChainLog, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[MockChainReadChain, MockChainReadConf, MockChainLog, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => TxSkel -> Sem effs ExtendedTxSkel balanceTxSkel skelUnbal@TxSkel {..} = do @@ -163,7 +164,7 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- | Computes optimal fee for a given skeleton and balances it around those fees. -- This uses a dichotomic search for an optimal "balanceable around" fee. computeFeeAndBalance :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => Peer -> Fee -> Fee -> @@ -220,7 +221,7 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske -- min ada requirements in the associated return collateral and the maximum -- number of collateral inputs authorized by protocol parameters. collateralsFromFee :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => -- | The fee from which these collaterals should be computed Fee -> -- | The optional candidate UTxOs to be used as collaterals, alongside the @@ -256,7 +257,7 @@ collateralsFromFee fee (Just (collateralIns, returnCollateralUser)) = do reachValue :: forall effs. - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => -- | The Utxos available to reach the value Utxos -> -- | The target value to reach @@ -390,7 +391,7 @@ reachValue utxos target fuel outputOrUser = do -- | Estimates the required fee for a given skeleton with a given initial fee -- and collaterals estimateTxSkelFee :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => TxSkel -> Fee -> Maybe Collaterals -> @@ -413,7 +414,7 @@ estimateTxSkelFee skel fee mCollaterals = do -- words, this ensures that the following equation holds: input value + minted -- value + withdrawn value = output value + burned value + fee + deposits computeBalancedTxSkel :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => Peer -> Utxos -> TxSkel -> @@ -497,7 +498,7 @@ computeBalancedTxSkel balancingUser balancingUtxos txSkel@TxSkel {..} (Script.lo -- See https://github.com/IntersectMBO/cardano-ledger/blob/master/docs/adr/2024-08-14_009-refscripts-fee-change.md -- for more information getMinAndMaxFee :: - (Members '[MockChainRead] effs) => + (Members '[MockChainReadChain, MockChainReadConf] effs) => Integer -> Sem effs (Fee, Fee) getMinAndMaxFee nbOfScripts = do diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs index d5759718b..e1ac6748e 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs @@ -23,7 +23,8 @@ import Cooked.MockChain.Automation.GenerateTx.ReferenceInputs import Cooked.MockChain.Automation.GenerateTx.Withdrawals import Cooked.MockChain.Automation.GenerateTx.Witness import Cooked.MockChain.Common -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.Skeleton import Data.Bifunctor (first) @@ -42,7 +43,7 @@ import Polysemy.Fail -- | Generates a body content from a skeleton txSkelToTxBodyContent :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => TxSkel -> Fee -> Maybe Collaterals -> @@ -87,7 +88,7 @@ txBodyContentToTxBody = -- | Generates an index with utxos known to a 'TxSkel' txSkelToIndex :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => TxSkel -> Maybe Collaterals -> Sem effs (Cardano.UTxO Cardano.ConwayEra) @@ -107,7 +108,7 @@ txSkelToIndex txSkel mCollaterals = do -- collateral information. This transaction body accounts for the actual -- execution units of each of the scripts involved in the skeleton. txSkelToTxBody :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => TxSkel -> Fee -> Maybe Collaterals -> @@ -169,7 +170,7 @@ txSignatoriesAndBodyToCardanoTx signatories txBody = Cardano.Tx txBody $ mapMayb -- | Generates a full Cardano transaction from a skeleton, fees and collaterals txSkelToCardanoTx :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => TxSkel -> Fee -> Maybe Collaterals -> diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs b/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs index 408fddb24..603d122a4 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs @@ -9,7 +9,8 @@ import Cardano.Ledger.PoolParams qualified as C.Ledger import Cardano.Ledger.Shelley.TxCert qualified as Shelley import Cooked.MockChain.Automation.GenerateTx.Credential import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.Skeleton.Certificate import Cooked.Skeleton.User @@ -24,7 +25,7 @@ import Polysemy.Error import Polysemy.Fail toDRep :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => Api.DRep -> Sem effs C.Ledger.DRep toDRep Api.DRepAlwaysAbstain = return C.Ledger.DRepAlwaysAbstain @@ -32,7 +33,7 @@ toDRep Api.DRepAlwaysNoConfidence = return C.Ledger.DRepAlwaysNoConfidence toDRep (Api.DRep (Api.DRepCredential cred)) = C.Ledger.DRepCredential <$> toDRepCredential cred toDelegatee :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => Api.Delegatee -> Sem effs Conway.Delegatee toDelegatee (Api.DelegStake pkh) = Conway.DelegStake <$> toStakePoolKeyHash pkh @@ -40,7 +41,7 @@ toDelegatee (Api.DelegVote dRep) = Conway.DelegVote <$> toDRep dRep toDelegatee (Api.DelegStakeVote pkh dRep) = liftA2 Conway.DelegStakeVote (toStakePoolKeyHash pkh) (toDRep dRep) toCertificate :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelCertificate -> Sem effs (Cardano.Certificate Cardano.ConwayEra) toCertificate txSkelCert = @@ -89,7 +90,7 @@ toCertificate txSkelCert = Conway.ConwayTxCertGov . (`Conway.ConwayResignCommitteeColdKey` SNothing) <$> toColdCredential cred toCertificateWitness :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelCertificate -> Sem effs (Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra)) toCertificateWitness = @@ -103,7 +104,7 @@ toCertificateWitness = -- | Builds a 'Cardano.TxCertificates' from a list of 'TxSkelCertificate' toCertificates :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => [TxSkelCertificate] -> Sem effs (Cardano.TxCertificates Cardano.BuildTx Cardano.ConwayEra) toCertificates = diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Collateral.hs b/src/Cooked/MockChain/Automation/GenerateTx/Collateral.hs index 98ef617e9..918f03934 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Collateral.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Collateral.hs @@ -8,7 +8,8 @@ where import Cardano.Api qualified as Cardano import Cooked.MockChain.Automation.GenerateTx.Output import Cooked.MockChain.Common -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.Skeleton.Output import Cooked.Skeleton.Value import Data.Map qualified as Map @@ -31,7 +32,7 @@ import Polysemy.Error -- These quantity should satisfy the equation (in terms of their values): -- collateral inputs = total collateral + return collateral toCollateralTriplet :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => Maybe Collaterals -> Sem effs diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs b/src/Cooked/MockChain/Automation/GenerateTx/Input.hs index 082a1db33..637d6ac65 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Input.hs @@ -3,7 +3,7 @@ module Cooked.MockChain.Automation.GenerateTx.Input (toTxInAndWitness) where import Cardano.Api qualified as Cardano import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Runtime.Error import Cooked.Skeleton import Ledger.Tx.CardanoAPI qualified as P.Ledger @@ -16,7 +16,7 @@ import Polysemy.Error -- | Converts a 'TxSkel' input, which consists of a 'Api.TxOutRef' and a -- 'TxSkelRedeemer', into a 'Cardano.TxIn', together with the appropriate witness. toTxInAndWitness :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => (Api.TxOutRef, TxSkelRedeemer) -> Sem effs diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Mint.hs b/src/Cooked/MockChain/Automation/GenerateTx/Mint.hs index 16ef83498..0ec5beca4 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Mint.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Mint.hs @@ -4,7 +4,7 @@ module Cooked.MockChain.Automation.GenerateTx.Mint (toMintValue) where import Cardano.Api qualified as Cardano import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Runtime.Error import Cooked.Skeleton.Mint import Cooked.Skeleton.User @@ -21,7 +21,7 @@ import Polysemy.Error -- | Converts a 'TxSkelMints' into a 'Cardano.TxMintValue' toMintValue :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelMints -> Sem effs (Cardano.TxMintValue Cardano.BuildTx Cardano.ConwayEra) toMintValue txSkelMints | txSkelMints == mempty = return Cardano.TxMintNone diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs b/src/Cooked/MockChain/Automation/GenerateTx/Output.hs index 8f99e2dad..f5584b6bb 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Output.hs @@ -2,7 +2,8 @@ module Cooked.MockChain.Automation.GenerateTx.Output (toCardanoTxOut) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.Skeleton.Datum import Cooked.Skeleton.Output import Ledger.Tx.CardanoAPI qualified as P.Ledger @@ -14,7 +15,7 @@ import Polysemy.Error -- | Converts a 'TxSkelOut' to the corresponding 'Cardano.TxOut' toCardanoTxOut :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => TxSkelOut -> Sem effs (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) toCardanoTxOut output = do diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Proposal.hs b/src/Cooked/MockChain/Automation/GenerateTx/Proposal.hs index 8a92b45df..a9268ec72 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Proposal.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Proposal.hs @@ -12,7 +12,8 @@ import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Anchor import Cooked.MockChain.Automation.GenerateTx.Credential import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.Skeleton.Proposal import Cooked.Skeleton.User @@ -84,7 +85,7 @@ toPParamsUpdate pChange ppu = -- | Translates a given skeleton proposal into a governance action toGovAction :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => GovernanceAction a -> StrictMaybe Conway.ScriptHash -> Sem effs (Conway.GovAction Emulator.EmulatorEra) @@ -100,7 +101,7 @@ toGovAction (TreasuryWithdrawals (Map.toList -> withdrawals)) sHash = -- | Translates a list of skeleton proposals into a proposal procedures toProposalProcedures :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => [TxSkelProposal] -> Sem effs (Cardano.TxProposalProcedures Cardano.BuildTx Cardano.ConwayEra) toProposalProcedures props | null props = return Cardano.TxProposalProceduresNone diff --git a/src/Cooked/MockChain/Automation/GenerateTx/ReferenceInputs.hs b/src/Cooked/MockChain/Automation/GenerateTx/ReferenceInputs.hs index 825f41294..16a16b3d7 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/ReferenceInputs.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/ReferenceInputs.hs @@ -2,7 +2,7 @@ module Cooked.MockChain.Automation.GenerateTx.ReferenceInputs (toInsReference) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.Skeleton import Data.Map qualified as Map import Data.Set qualified as Set @@ -17,7 +17,7 @@ import Polysemy.Error -- redeemers of the transaction, which can be gathered with -- 'txSkelReferenceInputsInRedeemers'. toInsReference :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, Error P.Ledger.ToCardanoError] effs) => TxSkel -> Sem effs (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra) toInsReference skel = do diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs b/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs index ff8f41328..56a1dbf4c 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs @@ -4,7 +4,8 @@ module Cooked.MockChain.Automation.GenerateTx.Withdrawals (toWithdrawals) where import Cardano.Api qualified as Cardano import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.Skeleton.User import Cooked.Skeleton.Withdrawal @@ -19,7 +20,7 @@ import Polysemy.Error -- | Takes a 'TxSkelWithdrawals' and transforms it into a 'Cardano.TxWithdrawals' toWithdrawals :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelWithdrawals -> Sem effs (Cardano.TxWithdrawals Cardano.BuildTx Cardano.ConwayEra) toWithdrawals withdrawals | withdrawals == mempty = return Cardano.TxWithdrawalsNone diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Witness.hs b/src/Cooked/MockChain/Automation/GenerateTx/Witness.hs index fc60ec8a3..d881911ce 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Witness.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Witness.hs @@ -6,7 +6,7 @@ module Cooked.MockChain.Automation.GenerateTx.Witness where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Runtime.Error import Cooked.Skeleton import Ledger.Address qualified as P.Ledger @@ -20,7 +20,7 @@ import Polysemy.Error -- | Translates a script and a reference script utxo into either a plutus script -- or a reference input containing the right script toPlutusScriptOrReferenceInput :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => VScript -> Maybe Api.TxOutRef -> Sem effs (Cardano.PlutusScriptOrReferenceInput lang) @@ -41,7 +41,7 @@ toPlutusScriptOrReferenceInput (Script.toScriptHash -> scriptHash) (Just scriptO -- 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 :: - ( Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError] effs, + ( Members '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs, ToVScript a ) => a -> diff --git a/src/Cooked/MockChain/Effect/Read.hs b/src/Cooked/MockChain/Effect/Read/Chain.hs similarity index 65% rename from src/Cooked/MockChain/Effect/Read.hs rename to src/Cooked/MockChain/Effect/Read/Chain.hs index 9857f272a..e58f14d22 100644 --- a/src/Cooked/MockChain/Effect/Read.hs +++ b/src/Cooked/MockChain/Effect/Read/Chain.hs @@ -1,26 +1,18 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | This module exposes primitives to query the current state of the --- blockchain. -module Cooked.MockChain.Effect.Read - ( -- * The 'MockChainRead' effect - MockChainRead, - - -- * 'MockChainRead' interpreters - runMockChainReadEmul, - runMockChainReadNode, - - -- * Queries related to protocol parameters - getParams, - getNetworkId, - govActionDeposit, - dRepDeposit, - stakeAddressDeposit, - stakePoolDeposit, +-- | This module exposes the user-facing primitives to query the current state +-- of the blockchain, such as the available UTxOs, the current slot, and the +-- current constitution or rewards. The lower-level configuration primitives +-- (protocol parameters, network id, era history, system start) live in the +-- internal 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect, which +-- this effect relies on during its own interpretation. +module Cooked.MockChain.Effect.Read.Chain + ( -- * The 'MockChainReadChain' effect + MockChainReadChain, + + -- * 'MockChainReadChain' interpreters + runMockChainReadChainEmul, + runMockChainReadChainNode, -- * Queries related to `Cooked.Skeleton.TxSkel` - txSkelDepositedValueInCertificates, - txSkelDepositedValueInProposals, txSkelAllScripts, txSkelInputScripts, txSkelInputValue, @@ -28,8 +20,6 @@ module Cooked.MockChain.Effect.Read -- * Queries related to time currentSlot, currentMSRange, - getEraHistory, - getSystemStart, getEnclosingSlot, slotRangeBefore, slotRangeAfter, @@ -54,16 +44,12 @@ where import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano hiding (TxIn) -import Cardano.Ledger.Conway qualified as Conway -import Cardano.Ledger.Conway.Core qualified as Conway -import Cardano.Ledger.Core qualified as C.Ledger -import Cardano.Ledger.Shelley.API qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Cardano.Slotting.Time qualified as Time -import Control.Lens qualified as Lens import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Credential import Cooked.MockChain.Common +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton @@ -92,178 +78,25 @@ import Polysemy.State -- | An effect that offers primitives to query the current state of the -- mockchain. As its name suggests, this effect is read-only and does not alter --- the state in any way. -data MockChainRead :: Effect where - GetParams :: MockChainRead m (C.Ledger.PParams Conway.ConwayEra) - GetNetworkId :: MockChainRead m Cardano.NetworkId - TxSkelOutByRef :: Api.TxOutRef -> MockChainRead m TxSkelOut - CurrentSlot :: MockChainRead m P.Ledger.Slot - GetEraHistory :: MockChainRead m Cardano.EraHistory - GetSystemStart :: MockChainRead m Time.SystemStart - SlotToMSRange :: P.Ledger.Slot -> MockChainRead m (Api.POSIXTime, Api.POSIXTime) - GetEnclosingSlot :: Api.POSIXTime -> MockChainRead m P.Ledger.Slot - AllUtxos :: MockChainRead m Utxos - UtxosAt :: (Script.ToAddress a) => a -> MockChainRead m Utxos - GetConstitutionScript :: MockChainRead m (Maybe VScript) - GetCurrentReward :: (Script.ToCredential c) => c -> MockChainRead m (Maybe Api.Lovelace) - -makeSem_ ''MockChainRead - --- | The interpretation for read-only effect with a stored 'MockChainState' -runMockChainReadEmul :: - forall effs a. - ( Members - '[ State MockChainState, - Error P.Ledger.ToCardanoError, - Error MockChainError, - Fail - ] - effs - ) => - Sem (MockChainRead : effs) a -> - Sem effs a -runMockChainReadEmul = interpret $ \case - GetParams -> gets $ Emulator.pEmulatorPParams . mcstParams - GetNetworkId -> gets $ Emulator.pNetworkId . mcstParams - TxSkelOutByRef oRef -> do - res <- gets $ Map.lookup oRef . mcstOutputs - case res of - Just (txSkelOut, True) -> return txSkelOut - _ -> throw $ MCEUnknownOutRef oRef - AllUtxos -> fetchUtxos $ const True - UtxosAt (Script.toAddress -> addr) -> fetchUtxos $ (== addr) . Script.toAddress - CurrentSlot -> gets $ view $ mcstLedgerStateL % to Emulator.getSlot - GetEraHistory -> gets $ Emulator.emulatorEraHistory . mcstParams - GetSystemStart -> gets $ Shelley.systemStart . Emulator.emulatorGlobals . mcstParams - SlotToMSRange slot -> do - slotConfig <- gets $ Emulator.pSlotConfig . mcstParams - case Emulator.slotToPOSIXTimeRange slotConfig slot of - Api.Interval - (Api.LowerBound (Api.Finite l) leftclosed) - (Api.UpperBound (Api.Finite r) rightclosed) -> - return - ( if leftclosed then l else l + 1, - if rightclosed then r else r - 1 - ) - _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" - GetEnclosingSlot t -> gets $ (`Emulator.posixTimeToEnclosingSlot` t) . Emulator.pSlotConfig . mcstParams - GetConstitutionScript -> gets $ view mcstConstitutionL - GetCurrentReward (Script.toCredential -> cred) -> do - stakeCredential <- toStakeCredential cred - gets $ - preview $ - mcstLedgerStateL - % to (Emulator.getReward stakeCredential) - % _Just - % to coerce - where - fetchUtxos decide = - gets $ - toListOf $ - mcstOutputsL - % to Map.toList - % traversed - % filtered (snd . snd) - % filtered (decide . fst . snd) - % to (fmap fst) - --- | Returns the emulator parameters, including protocol parameters -getParams :: - (Member MockChainRead effs) => - Sem effs (C.Ledger.PParams Conway.ConwayEra) - --- | Returns the network id of the current chain -getNetworkId :: - (Member MockChainRead effs) => - Sem effs Cardano.NetworkId - --- | Retrieves the required governance action deposit amount -govActionDeposit :: - (Member MockChainRead effs) => - Sem effs Api.Lovelace -govActionDeposit = - getParams - <&> Api.Lovelace - . Cardano.unCoin - . Lens.view Conway.ppGovActionDepositL - --- | Retrieves the required drep deposit amount -dRepDeposit :: - (Member MockChainRead effs) => - Sem effs Api.Lovelace -dRepDeposit = - getParams - <&> Api.Lovelace - . Cardano.unCoin - . Lens.view Conway.ppDRepDepositL - --- | Retrieves the required stake address deposit amount -stakeAddressDeposit :: - (Member MockChainRead effs) => - Sem effs Api.Lovelace -stakeAddressDeposit = - getParams - <&> Api.Lovelace - . Cardano.unCoin - . Lens.view Conway.ppKeyDepositL - --- | Retrieves the required stake pool deposit amount -stakePoolDeposit :: - (Member MockChainRead effs) => - Sem effs Api.Lovelace -stakePoolDeposit = - getParams - <&> Api.Lovelace - . Cardano.unCoin - . Lens.view Conway.ppPoolDepositL - --- | 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 :: - (Member MockChainRead effs) => - TxSkel -> - Sem effs Api.Lovelace -txSkelDepositedValueInCertificates txSkel = do - sDep <- stakeAddressDeposit - dDep <- dRepDeposit - pDep <- stakePoolDeposit - return $ - foldOf - ( txSkelCertificatesL - % traversed - % to - ( \case - TxSkelCertificate _ StakingRegister {} -> sDep - TxSkelCertificate _ StakingRegisterDelegate {} -> sDep - TxSkelCertificate _ StakingUnRegister {} -> -sDep - TxSkelCertificate _ DRepRegister {} -> dDep - TxSkelCertificate _ DRepUnRegister {} -> -dDep - TxSkelCertificate _ PoolRegister {} -> pDep - -- There is no special case for 'PoolRetire' because the deposit - -- is given back to the reward account. - _ -> Api.Lovelace 0 - ) - ) - txSkel - --- | Retrieves the total amount of lovelace deposited in proposals in this --- skeleton (equal to `govActionDeposit` times the number of proposals) -txSkelDepositedValueInProposals :: - (Member MockChainRead effs) => - TxSkel -> - Sem effs Api.Lovelace -txSkelDepositedValueInProposals TxSkel {txSkelProposals} = - govActionDeposit - <&> Api.Lovelace - . (toInteger (length txSkelProposals) *) - . Api.getLovelace +-- the state in any way. This is the user-facing read effect; its interpreters +-- rely on the internal +-- 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect to resolve the +-- fixed chain configuration. +data MockChainReadChain :: Effect where + TxSkelOutByRef :: Api.TxOutRef -> MockChainReadChain m TxSkelOut + CurrentSlot :: MockChainReadChain m P.Ledger.Slot + SlotToMSRange :: P.Ledger.Slot -> MockChainReadChain m (Api.POSIXTime, Api.POSIXTime) + GetEnclosingSlot :: Api.POSIXTime -> MockChainReadChain m P.Ledger.Slot + AllUtxos :: MockChainReadChain m Utxos + UtxosAt :: (Script.ToAddress a) => a -> MockChainReadChain m Utxos + GetConstitutionScript :: MockChainReadChain m (Maybe VScript) + GetCurrentReward :: (Script.ToCredential c) => c -> MockChainReadChain m (Maybe Api.Lovelace) + +makeSem_ ''MockChainReadChain -- | Returns all scripts involved in this 'TxSkel' txSkelAllScripts :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => TxSkel -> Sem effs [VScript] txSkelAllScripts txSkel = do @@ -274,7 +107,7 @@ txSkelAllScripts txSkel = do -- | Returns all scripts which guard transaction inputs txSkelInputScripts :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => TxSkel -> Sem effs [VScript] txSkelInputScripts = @@ -285,7 +118,7 @@ txSkelInputScripts = -- | look up the UTxOs the transaction consumes, and sum their values. txSkelInputValue :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => TxSkel -> Sem effs Api.Value txSkelInputValue = @@ -296,44 +129,32 @@ txSkelInputValue = -- | Returns the current slot currentSlot :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => Sem effs P.Ledger.Slot --- | Returns the era history of the chain, which notably allows converting slots --- into epochs (see 'Cardano.slotToEpoch'). -getEraHistory :: - (Member MockChainRead effs) => - Sem effs Cardano.EraHistory - --- | Returns the system start time of the chain, that is the UTC time at which --- the first slot begins. -getSystemStart :: - (Member MockChainRead effs) => - Sem effs Time.SystemStart - -- | Returns the closed ms interval corresponding to the slot with the given -- number. slotToMSRange :: - (Members '[MockChainRead, Fail] effs) => + (Members '[MockChainReadChain, Fail] effs) => P.Ledger.Slot -> Sem effs (Api.POSIXTime, Api.POSIXTime) -- | Returns the closed ms interval corresponding to the current slot currentMSRange :: - (Members '[MockChainRead, Fail] effs) => + (Members '[MockChainReadChain, Fail] effs) => Sem effs (Api.POSIXTime, Api.POSIXTime) currentMSRange = slotToMSRange =<< currentSlot -- | Return the slot that contains the given time. See 'slotToMSRange' for -- some satisfied equational properties. getEnclosingSlot :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => Api.POSIXTime -> Sem effs P.Ledger.Slot -- | The infinite range of slots ending before or at the given time slotRangeBefore :: - (Members '[MockChainRead, Fail] effs) => + (Members '[MockChainReadChain, Fail] effs) => Api.POSIXTime -> Sem effs P.Ledger.SlotRange slotRangeBefore t = do @@ -346,7 +167,7 @@ slotRangeBefore t = do -- | The infinite range of slots starting after or at the given time slotRangeAfter :: - (Members '[MockChainRead, Fail] effs) => + (Members '[MockChainReadChain, Fail] effs) => Api.POSIXTime -> Sem effs P.Ledger.SlotRange slotRangeAfter t = do @@ -356,12 +177,12 @@ slotRangeAfter t = do -- | Returns a list of all currently known outputs allUtxos :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => Sem effs Utxos -- | Returns a list of all UTxOs at a certain address. utxosAt :: - ( Member MockChainRead effs, + ( Member MockChainReadChain effs, Script.ToAddress cred ) => cred -> @@ -369,7 +190,7 @@ utxosAt :: -- | Returns an output given a reference to it txSkelOutByRef :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => Api.TxOutRef -> Sem effs TxSkelOut @@ -379,7 +200,7 @@ txSkelOutByRef :: -- interest right from the start and avoid querying the chain for them -- afterwards using 'allUtxos' or similar functions. utxosFromCardanoTx :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => P.Ledger.CardanoTx -> Sem effs [(Api.TxOutRef, TxSkelOut)] utxosFromCardanoTx = @@ -390,7 +211,7 @@ utxosFromCardanoTx = -- | 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. lookupUtxos :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => [Api.TxOutRef] -> Sem effs (Map Api.TxOutRef TxSkelOut) lookupUtxos = @@ -400,7 +221,7 @@ lookupUtxos = -- | Retrieves an output and views a specific element out of it viewByRef :: - ( Member MockChainRead effs, + ( Member MockChainReadChain effs, Is g A_Getter ) => Optic' g is TxSkelOut c -> @@ -410,7 +231,7 @@ viewByRef optic = (view optic <$>) . txSkelOutByRef -- | Retrieves an output and previews a specific element out of it previewByRef :: - ( Member MockChainRead effs, + ( Member MockChainReadChain effs, Is af An_AffineFold ) => Optic' af is TxSkelOut c -> @@ -420,24 +241,81 @@ previewByRef optic = (preview optic <$>) . txSkelOutByRef -- | Gets the current official constitution script getConstitutionScript :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => Sem effs (Maybe VScript) -- | Gets the current reward associated with a credential getCurrentReward :: - ( Member MockChainRead effs, + ( Member MockChainReadChain effs, Script.ToCredential c ) => c -> Sem effs (Maybe Api.Lovelace) --- | Interpret the `MockChainRead` effect by talking to a deployed node through --- a `Cardano.LocalNodeConnectInfo` (socket path and network id) provided via a --- `Reader`, running in a stack featuring @IO@ (via `Embed`). -runMockChainReadNode :: +-- | The interpretation for read-only effect with a stored 'MockChainState' +runMockChainReadChainEmul :: + forall effs a. + ( Members + '[ State MockChainState, + Error P.Ledger.ToCardanoError, + Error MockChainError, + Fail + ] + effs + ) => + Sem (MockChainReadChain : effs) a -> + Sem effs a +runMockChainReadChainEmul = interpret $ \case + TxSkelOutByRef oRef -> do + res <- gets $ Map.lookup oRef . mcstOutputs + case res of + Just (txSkelOut, True) -> return txSkelOut + _ -> throw $ MCEUnknownOutRef oRef + AllUtxos -> fetchUtxos $ const True + UtxosAt (Script.toAddress -> addr) -> fetchUtxos $ (== addr) . Script.toAddress + CurrentSlot -> gets $ view $ mcstLedgerStateL % to Emulator.getSlot + SlotToMSRange slot -> do + slotConfig <- gets $ Emulator.pSlotConfig . mcstParams + case Emulator.slotToPOSIXTimeRange slotConfig slot of + Api.Interval + (Api.LowerBound (Api.Finite l) leftclosed) + (Api.UpperBound (Api.Finite r) rightclosed) -> + return + ( if leftclosed then l else l + 1, + if rightclosed then r else r - 1 + ) + _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" + GetEnclosingSlot t -> gets $ (`Emulator.posixTimeToEnclosingSlot` t) . Emulator.pSlotConfig . mcstParams + GetConstitutionScript -> gets $ view mcstConstitutionL + GetCurrentReward (Script.toCredential -> cred) -> do + stakeCredential <- toStakeCredential cred + gets $ + preview $ + mcstLedgerStateL + % to (Emulator.getReward stakeCredential) + % _Just + % to coerce + where + fetchUtxos decide = + gets $ + toListOf $ + mcstOutputsL + % to Map.toList + % traversed + % filtered (snd . snd) + % filtered (decide . fst . snd) + % to (fmap fst) + +-- | Interpret the `MockChainReadChain` effect by talking to a deployed node +-- through a `Cardano.LocalNodeConnectInfo` (socket path and network id) +-- provided via a `Reader`, running in a stack featuring @IO@ (via `Embed`). The +-- fixed chain configuration is resolved through the internal +-- 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect. +runMockChainReadChainNode :: forall effs a. ( Members '[ Embed IO, + MockChainReadConf, Error Cardano.UnsupportedNtcVersionError, Error Cardano.EraMismatch, Error Cardano.AcquiringFailure, @@ -448,29 +326,25 @@ runMockChainReadNode :: ] effs ) => - Sem (MockChainRead : effs) a -> + Sem (MockChainReadChain : effs) a -> Sem effs a -runMockChainReadNode = interpret $ \case - GetParams -> queryAndHandleErrors $ Cardano.queryProtocolParameters Cardano.ShelleyBasedEraConway - GetNetworkId -> asks Cardano.localNodeNetworkId +runMockChainReadChainNode = interpret $ \case CurrentSlot -> ask >>= fmap chainTipSlot . embed . Cardano.getLocalChainTip - GetEraHistory -> queryAndHandleError Cardano.queryEraHistory - GetSystemStart -> queryAndHandleError Cardano.querySystemStart SlotToMSRange slot -> do - eraHistory <- queryAndHandleError Cardano.queryEraHistory - systemStart <- queryAndHandleError Cardano.querySystemStart + eraHistory <- getEraHistory + systemStart <- getSystemStart (relStart, slotLen) <- fromEither $ Cardano.getProgress (toSlotNo slot) eraHistory let startUTC = Time.fromRelativeTime systemStart relStart endUTC = Time.getSlotLength slotLen `addUTCTime` startUTC return (utcToPOSIXTime startUTC, utcToPOSIXTime endUTC - 1) GetEnclosingSlot t -> do - eraHistory <- queryAndHandleError Cardano.queryEraHistory - systemStart <- queryAndHandleError Cardano.querySystemStart + eraHistory <- getEraHistory + systemStart <- getSystemStart let relTime = Time.toRelativeTime systemStart $ posixTimeToUTC t fromSlotNo <$> fromEither (Cardano.getSlotForRelativeTime relTime eraHistory) AllUtxos -> queryUtxosAndHandleErrors Cardano.QueryUTxOWhole UtxosAt (Script.toAddress -> addr) -> do - networkId <- asks Cardano.localNodeNetworkId + networkId <- getNetworkId (Cardano.AddressInEra _ cAddr) <- fromEither $ P.Ledger.toCardanoAddressInEra networkId addr queryUtxosAndHandleErrors $ Cardano.QueryUTxOByAddress $ Set.singleton $ Cardano.toAddressAny cAddr TxSkelOutByRef oRef -> do @@ -495,7 +369,7 @@ runMockChainReadNode = interpret $ \case case mScriptHash of SNothing -> return Nothing SJust (Cardano.ScriptHash -> scriptHash) -> do - networkId <- asks Cardano.localNodeNetworkId + networkId <- getNetworkId utxo <- queryUtxosAndHandleErrors $ Cardano.QueryUTxOByAddress $ @@ -512,7 +386,7 @@ runMockChainReadNode = interpret $ \case Script.toScriptHash script == Script.toScriptHash scriptHash ] GetCurrentReward (Script.toCredential -> cred) -> do - networkId <- asks Cardano.localNodeNetworkId + networkId <- getNetworkId stakeCred <- toStakeCredential cred (rewards, _) <- queryAndHandleErrors $ diff --git a/src/Cooked/MockChain/Effect/Read/Conf.hs b/src/Cooked/MockChain/Effect/Read/Conf.hs new file mode 100644 index 000000000..06a6b69d8 --- /dev/null +++ b/src/Cooked/MockChain/Effect/Read/Conf.hs @@ -0,0 +1,212 @@ +-- | This module exposes internal, configuration-level primitives to query the +-- fixed configuration of the chain, such as its protocol parameters, network +-- id, era history and system start. These primitives are not meant to be used +-- directly when writing traces: they are an implementation detail backing the +-- user-facing 'Cooked.MockChain.Effect.Read.Chain.MockChainReadChain' effect, +-- and they are deliberately not re-exported through the 'Cooked.MockChain' +-- umbrella module. +module Cooked.MockChain.Effect.Read.Conf + ( -- * The 'MockChainReadConf' effect + MockChainReadConf, + + -- * 'MockChainReadConf' interpreters + runMockChainReadConfEmul, + runMockChainReadConfNode, + + -- * Queries related to protocol parameters + getParams, + getNetworkId, + govActionDeposit, + dRepDeposit, + stakeAddressDeposit, + stakePoolDeposit, + + -- * Queries related to time configuration + getEraHistory, + getSystemStart, + + -- * Queries related to `Cooked.Skeleton.TxSkel` deposits + txSkelDepositedValueInCertificates, + txSkelDepositedValueInProposals, + ) +where + +import Cardano.Api qualified as Cardano +import Cardano.Ledger.Conway qualified as Conway +import Cardano.Ledger.Conway.Core qualified as Conway +import Cardano.Ledger.Core qualified as C.Ledger +import Cardano.Ledger.Shelley.API qualified as Shelley +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Cardano.Slotting.Time qualified as Time +import Control.Lens qualified as Lens +import Cooked.MockChain.Runtime.State +import Cooked.Skeleton +import Data.Functor +import Optics.Core +import PlutusLedgerApi.V3 qualified as Api +import Polysemy +import Polysemy.Error +import Polysemy.Reader +import Polysemy.State + +-- | An effect that offers primitives to query the fixed configuration of the +-- chain (protocol parameters, network id, era history and system start). As its +-- name suggests, this effect is read-only and does not alter the state in any +-- way. It is internal to the library and backs the user-facing +-- 'Cooked.MockChain.Effect.Read.Chain.MockChainReadChain' effect. +data MockChainReadConf :: Effect where + GetParams :: MockChainReadConf m (C.Ledger.PParams Conway.ConwayEra) + GetNetworkId :: MockChainReadConf m Cardano.NetworkId + GetEraHistory :: MockChainReadConf m Cardano.EraHistory + GetSystemStart :: MockChainReadConf m Time.SystemStart + +makeSem_ ''MockChainReadConf + +-- | The interpretation for the configuration effect with a stored +-- 'MockChainState' +runMockChainReadConfEmul :: + (Member (State MockChainState) effs) => + Sem (MockChainReadConf : effs) a -> + Sem effs a +runMockChainReadConfEmul = interpret $ \case + GetParams -> gets $ Emulator.pEmulatorPParams . mcstParams + GetNetworkId -> gets $ Emulator.pNetworkId . mcstParams + GetEraHistory -> gets $ Emulator.emulatorEraHistory . mcstParams + GetSystemStart -> gets $ Shelley.systemStart . Emulator.emulatorGlobals . mcstParams + +-- | Interpret the `MockChainReadConf` effect by talking to a deployed node +-- through a `Cardano.LocalNodeConnectInfo` (socket path and network id) provided +-- via a `Reader`, running in a stack featuring @IO@ (via `Embed`). +runMockChainReadConfNode :: + ( Members + '[ Embed IO, + Error Cardano.UnsupportedNtcVersionError, + Error Cardano.EraMismatch, + Error Cardano.AcquiringFailure, + Reader Cardano.LocalNodeConnectInfo + ] + effs + ) => + Sem (MockChainReadConf : effs) a -> + Sem effs a +runMockChainReadConfNode = interpret $ \case + GetParams -> queryAndHandleErrors $ Cardano.queryProtocolParameters Cardano.ShelleyBasedEraConway + GetNetworkId -> asks Cardano.localNodeNetworkId + GetEraHistory -> queryAndHandleError Cardano.queryEraHistory + GetSystemStart -> queryAndHandleError Cardano.querySystemStart + where + -- Fetches the local node info, embeds a query in IO and handles errors + query q = do + conn <- ask + response <- embed $ Cardano.executeLocalStateQueryExpr conn Cardano.VolatileTip q + fromEither response + -- Handles one more layer of errors from the response of a query + queryAndHandleError q = query q >>= fromEither + -- Handles a second layer of error from the response of a query + queryAndHandleErrors q = queryAndHandleError q >>= fromEither + +-- | Returns the emulator parameters, including protocol parameters +getParams :: + (Member MockChainReadConf effs) => + Sem effs (C.Ledger.PParams Conway.ConwayEra) + +-- | Returns the network id of the current chain +getNetworkId :: + (Member MockChainReadConf effs) => + Sem effs Cardano.NetworkId + +-- | Returns the era history of the chain, which notably allows converting slots +-- into epochs (see 'Cardano.slotToEpoch'). +getEraHistory :: + (Member MockChainReadConf effs) => + Sem effs Cardano.EraHistory + +-- | Returns the system start time of the chain, that is the UTC time at which +-- the first slot begins. +getSystemStart :: + (Member MockChainReadConf effs) => + Sem effs Time.SystemStart + +-- | Retrieves the required governance action deposit amount +govActionDeposit :: + (Member MockChainReadConf effs) => + Sem effs Api.Lovelace +govActionDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppGovActionDepositL + +-- | Retrieves the required drep deposit amount +dRepDeposit :: + (Member MockChainReadConf effs) => + Sem effs Api.Lovelace +dRepDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppDRepDepositL + +-- | Retrieves the required stake address deposit amount +stakeAddressDeposit :: + (Member MockChainReadConf effs) => + Sem effs Api.Lovelace +stakeAddressDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppKeyDepositL + +-- | Retrieves the required stake pool deposit amount +stakePoolDeposit :: + (Member MockChainReadConf effs) => + Sem effs Api.Lovelace +stakePoolDeposit = + getParams + <&> Api.Lovelace + . Cardano.unCoin + . Lens.view Conway.ppPoolDepositL + +-- | 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 :: + (Member MockChainReadConf effs) => + TxSkel -> + Sem effs Api.Lovelace +txSkelDepositedValueInCertificates txSkel = do + sDep <- stakeAddressDeposit + dDep <- dRepDeposit + pDep <- stakePoolDeposit + return $ + foldOf + ( txSkelCertificatesL + % traversed + % to + ( \case + TxSkelCertificate _ StakingRegister {} -> sDep + TxSkelCertificate _ StakingRegisterDelegate {} -> sDep + TxSkelCertificate _ StakingUnRegister {} -> -sDep + TxSkelCertificate _ DRepRegister {} -> dDep + TxSkelCertificate _ DRepUnRegister {} -> -dDep + TxSkelCertificate _ PoolRegister {} -> pDep + -- There is no special case for 'PoolRetire' because the deposit + -- is given back to the reward account. + _ -> Api.Lovelace 0 + ) + ) + txSkel + +-- | Retrieves the total amount of lovelace deposited in proposals in this +-- skeleton (equal to `govActionDeposit` times the number of proposals) +txSkelDepositedValueInProposals :: + (Member MockChainReadConf effs) => + TxSkel -> + Sem effs Api.Lovelace +txSkelDepositedValueInProposals TxSkel {txSkelProposals} = + govActionDeposit + <&> Api.Lovelace + . (toInteger (length txSkelProposals) *) + . Api.getLovelace diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index df4b000f3..2ca1a38de 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -41,7 +41,8 @@ import Cooked.MockChain.Automation.GenerateTx.Body import Cooked.MockChain.Automation.GenerateTx.Output import Cooked.MockChain.Common import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton @@ -80,7 +81,8 @@ runMockChainWrite :: Error P.Ledger.ToCardanoError, Error MockChainError, MockChainLog, - MockChainRead, + MockChainReadChain, + MockChainReadConf, Fail ] effs @@ -225,6 +227,8 @@ runMockChainWrite = interpret $ \case (_, P.Ledger.FailPhase2 {}) | Nothing <- mCollaterals -> fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" + -- We increase the slot number + modify' $ over mcstLedgerStateL Emulator.nextSlot -- We log the validated transaction logEvent $ MCLogNewTx (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) -- We return the validated transaction @@ -234,7 +238,7 @@ runMockChainWrite = interpret $ \case waitNSlots :: (Member MockChainWrite effs) => Integer -> Sem effs P.Ledger.Slot -- | Wait for a certain slot, or throws an error if the slot is already past -awaitSlot :: (Members '[MockChainRead, MockChainWrite] effs) => P.Ledger.Slot -> Sem effs P.Ledger.Slot +awaitSlot :: (Members '[MockChainReadChain, MockChainWrite] effs) => P.Ledger.Slot -> Sem effs P.Ledger.Slot awaitSlot (P.Ledger.Slot targetSlot) = do P.Ledger.Slot now <- currentSlot waitNSlots (targetSlot - now) @@ -242,17 +246,17 @@ awaitSlot (P.Ledger.Slot targetSlot) = do -- | Waits until the current slot becomes greater or equal to the slot -- containing the given POSIX time. Note that that it might not wait for -- anything if the current slot is large enough. -awaitEnclosingSlot :: (Members '[MockChainRead, MockChainWrite] effs) => Api.POSIXTime -> Sem effs P.Ledger.Slot +awaitEnclosingSlot :: (Members '[MockChainReadChain, MockChainWrite] effs) => Api.POSIXTime -> Sem effs P.Ledger.Slot awaitEnclosingSlot time = getEnclosingSlot time >>= awaitSlot -- | Wait a given number of ms from the lower bound of the current slot and -- returns the current slot after waiting. -waitNMSFromSlotLowerBound :: (Members '[MockChainRead, MockChainWrite, Fail] effs) => Integer -> Sem effs P.Ledger.Slot +waitNMSFromSlotLowerBound :: (Members '[MockChainReadChain, MockChainWrite, Fail] effs) => Integer -> Sem effs P.Ledger.Slot waitNMSFromSlotLowerBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . fst -- | Wait a given number of ms from the upper bound of the current slot and -- returns the current slot after waiting. -waitNMSFromSlotUpperBound :: (Members '[MockChainRead, MockChainWrite, Fail] effs) => Integer -> Sem effs P.Ledger.Slot +waitNMSFromSlotUpperBound :: (Members '[MockChainReadChain, MockChainWrite, Fail] effs) => Integer -> Sem effs P.Ledger.Slot waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd -- | Generates, balances and validates a transaction from a skeleton, and @@ -260,7 +264,7 @@ waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ validateTxSkel :: (Member MockChainWrite effs) => TxSkel -> Sem effs (P.Ledger.CardanoTx, Utxos) -- | Same as `validateTxSkel`, but only returns the generated UTxOs -validateTxSkel' :: (Members '[MockChainRead, MockChainWrite] effs) => TxSkel -> Sem effs Utxos +validateTxSkel' :: (Members '[MockChainReadChain, MockChainWrite] effs) => TxSkel -> Sem effs Utxos validateTxSkel' = fmap snd . validateTxSkel -- | Same as `validateTxSkel`, but discards the returned transaction diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index 25c2648cd..a82cd78f4 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -50,7 +50,8 @@ where import Cooked.Ltl import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Misc -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Effect.Write import Cooked.MockChain.Run.Runnable import Cooked.MockChain.Run.Tweak @@ -69,7 +70,7 @@ import Polysemy.Writer -- | The most direct stack of effects to run a mockchain type DirectEffs = '[ MockChainWrite, - MockChainRead, + MockChainReadChain, MockChainMisc, Fail ] @@ -88,21 +89,26 @@ instance RunnableMockChain DirectEffs where . runToCardanoErrorInMockChainError . runFailInMockChainError . runMockChainMisc fromAlias fromNote fromAssert - . runMockChainReadEmul + . runMockChainReadConfEmul + . runMockChainReadChainEmul . runMockChainWrite - . insertAt @4 - @[ Error P.Ledger.ToCardanoError, - Error MockChainError, - State MockChainState, - MockChainLog, - Writer MockChainJournal - ] + . insertAt @5 + @'[ Error P.Ledger.ToCardanoError, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer MockChainJournal + ] + . insertAt @2 + @'[ MockChainReadConf + ] -- | A stack of effects aimed at being used as modifications for a -- `FullMockChain` computation type FullTweakEffs = '[ MockChainMisc, - MockChainRead, + MockChainReadChain, + MockChainReadConf, Fail, Error P.Ledger.ToCardanoError, Error MockChainError, @@ -122,7 +128,8 @@ type FullEffs = ModifyLocally (UntypedTweak FullTweakEffs), State [Ltl (UntypedTweak FullTweakEffs)], MockChainMisc, - MockChainRead, + MockChainReadChain, + MockChainReadConf, Fail, Error P.Ledger.ToCardanoError, Error MockChainError, @@ -145,7 +152,8 @@ instance RunnableMockChain FullEffs where . runError . runToCardanoErrorInMockChainError . runFailInMockChainError - . runMockChainReadEmul + . runMockChainReadConfEmul + . runMockChainReadChainEmul . runMockChainMisc fromAlias fromNote fromAssert . evalState [] . runModifyLocally @@ -158,7 +166,7 @@ instance RunnableMockChain FullEffs where type ExtendedStagedTweakEffs extraEff = '[ extraEff, MockChainMisc, - MockChainRead, + MockChainReadChain, Fail ] @@ -173,7 +181,7 @@ type ExtendedStagedEffs extraEff = MockChainWrite, extraEff, MockChainMisc, - MockChainRead, + MockChainReadChain, Fail, NonDet ] @@ -197,25 +205,29 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runError . runToCardanoErrorInMockChainError . runFailInMockChainError - . runMockChainReadEmul + . runMockChainReadConfEmul + . runMockChainReadChainEmul . runMockChainMisc fromAlias fromNote fromAssert . runInterpretAlone . evalState [] . runModifyLocally . runMockChainWrite - . insertAt @7 - @[ Error P.Ledger.ToCardanoError, - Error MockChainError, - State MockChainState, - MockChainLog, - Writer MockChainJournal - ] + . insertAt @8 + @'[ Error P.Ledger.ToCardanoError, + Error MockChainError, + State MockChainState, + MockChainLog, + Writer MockChainJournal + ] . reinterpretMockChainWriteWithTweak @(ExtendedStagedTweakEffs extraEff) + . insertAt @6 + @'[ MockChainReadConf + ] . runModifyGlobally . insertAt @2 - @[ ModifyLocally (UntypedTweak (ExtendedStagedTweakEffs extraEff)), - State [Ltl (UntypedTweak (ExtendedStagedTweakEffs extraEff))] - ] + @'[ ModifyLocally (UntypedTweak (ExtendedStagedTweakEffs extraEff)), + State [Ltl (UntypedTweak (ExtendedStagedTweakEffs extraEff))] + ] -- | A stack of effects aimed at being used as modifications for a -- `StagedMockChain` computation diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index c359cf599..2c0e9d3c3 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/MockChain/UtxoSearch.hs @@ -45,7 +45,7 @@ where import Control.Monad (filterM, forM) import Cooked.Families hiding (Member) import Cooked.MockChain.Common -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.Skeleton.Datum import Cooked.Skeleton.Output import Cooked.Skeleton.Value @@ -115,7 +115,7 @@ getTxOutRefsAndOutputs = fmap (fmap (\(oRef, HCons output _) -> (oRef, output))) -- | Searches for utxos at a given address with a given filter utxosAtSearch :: - (Member MockChainRead effs, Script.ToAddress pkh) => + (Member MockChainReadChain effs, Script.ToAddress pkh) => pkh -> (UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els @@ -123,14 +123,14 @@ utxosAtSearch pkh filters = filters $ beginSearch $ utxosAt pkh -- | Searches for all the known utxos with a given filter allUtxosSearch :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => (UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els allUtxosSearch filters = filters $ beginSearch allUtxos -- | Searches for utxos belonging to a given list with a given filter txSkelOutByRefSearch :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => [Api.TxOutRef] -> (UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els @@ -139,7 +139,7 @@ txSkelOutByRefSearch utxos filters = -- | Searches for utxos belonging to a given list with no filter txSkelOutByRefSearch' :: - (Member MockChainRead effs) => + (Member MockChainReadChain effs) => [Api.TxOutRef] -> UtxoSearch effs '[] txSkelOutByRefSearch' = (`txSkelOutByRefSearch` id) diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index 41869ffd5..b2870cbdc 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -1,6 +1,6 @@ module Spec.Slot (tests) where -import Cooked.MockChain.Effect.Read +import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Data.Default @@ -16,7 +16,7 @@ import Test.Tasty.QuickCheck runSlot :: Sem - '[ MockChainRead, + '[ MockChainReadChain, State MockChainState, Fail, Error P.Ledger.ToCardanoError, @@ -30,7 +30,7 @@ runSlot = . runToCardanoErrorInMockChainError . runFailInMockChainError . evalState def - . runMockChainReadEmul + . runMockChainReadChainEmul tests :: TestTree tests = From 88cee2181feca52c87b0b6acd4b65e3b293fd1d1 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Aug 2026 17:42:29 +0200 Subject: [PATCH 09/18] extracting ValidateTxSkel from Write --- cooked-validators.cabal | 1 + src/Cooked/MockChain.hs | 1 + src/Cooked/MockChain/Effect/Validation.hs | 157 ++++++++++++++++++++++ src/Cooked/MockChain/Effect/Write.hs | 101 +------------- src/Cooked/MockChain/Run/Instances.hs | 23 ++-- src/Cooked/MockChain/Run/Tweak.hs | 31 +++-- 6 files changed, 190 insertions(+), 124 deletions(-) create mode 100644 src/Cooked/MockChain/Effect/Validation.hs diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 0bf228626..1e2e01d70 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -46,6 +46,7 @@ library Cooked.MockChain.Effect.Misc Cooked.MockChain.Effect.Read.Chain Cooked.MockChain.Effect.Read.Conf + Cooked.MockChain.Effect.Validation Cooked.MockChain.Effect.Write Cooked.MockChain.Run.Instances Cooked.MockChain.Run.Runnable diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index 3d7f32ecc..90cba3e76 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -7,6 +7,7 @@ import Cooked.MockChain.Common as X import Cooked.MockChain.Effect.Misc as X import Cooked.MockChain.Effect.Read.Chain as X import Cooked.MockChain.Effect.Read.Conf as X +import Cooked.MockChain.Effect.Validation as X import Cooked.MockChain.Effect.Write as X import Cooked.MockChain.Run.Instances as X import Cooked.MockChain.Run.Runnable as X diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs new file mode 100644 index 000000000..09009c494 --- /dev/null +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module exposes the `MockChainValidate` effect, which is responsible +-- for turning a `Cooked.Skeleton.TxSkel` into an actual transaction and +-- submitting it to the emulated ledger. This includes running the whole +-- adjustment pipeline (auto-filling, balancing and transaction generation) and +-- updating the mockchain state based on the validation outcome. +module Cooked.MockChain.Effect.Validation + ( -- * The `MockChainValidate` effect + MockChainValidate (..), + runMockChainValidate, + + -- * Sending `Cooked.Skeleton.TxSkel`s for validation + validateTxSkel, + validateTxSkel', + validateTxSkel_, + ) +where + +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Control.Monad +import Cooked.MockChain.Automation.AutoFilling.Constitution +import Cooked.MockChain.Automation.AutoFilling.MinAda +import Cooked.MockChain.Automation.AutoFilling.ReferenceScripts +import Cooked.MockChain.Automation.AutoFilling.Withdrawals +import Cooked.MockChain.Automation.Balancing +import Cooked.MockChain.Automation.GenerateTx.Body +import Cooked.MockChain.Common +import Cooked.MockChain.Effect.Log +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf +import Cooked.MockChain.Runtime.Error +import Cooked.MockChain.Runtime.State +import Cooked.Skeleton +import Cooked.Tweak.Common +import Cooked.Tweak.Query +import Data.Map.Strict qualified as Map +import Ledger.Index qualified as P.Ledger +import Ledger.Orphans () +import Ledger.Tx qualified as P.Ledger +import Ledger.Tx.CardanoAPI qualified as P.Ledger +import Optics.Core +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.State + +-- | An effect that offers the ability to send a `Cooked.Skeleton.TxSkel` for +-- validation on the emulated blockchain. +data MockChainValidate :: Effect where + ValidateTxSkel :: TxSkel -> MockChainValidate m (P.Ledger.CardanoTx, Utxos) + +makeSem_ ''MockChainValidate + +-- | Interpretes the `MockChainValidate` effect +runMockChainValidate :: + forall effs a. + ( Members + '[ State MockChainState, + Error P.Ledger.ToCardanoError, + Error MockChainError, + MockChainLog, + MockChainReadChain, + MockChainReadConf, + Fail + ] + effs + ) => + Sem (MockChainValidate : effs) a -> + Sem effs a +runMockChainValidate = interpret $ \case + ValidateTxSkel skel -> fmap snd $ runTweak skel $ do + params <- gets mcstParams + -- We retrieve the current skeleton options + TxSkelOpts {..} <- viewTweak txSkelOptsL + -- We log the submission of the new skeleton + viewTweak simple >>= logEvent . MCLogSubmittedTxSkel + -- We ensure that the outputs have the required minimal amount of ada, when + -- requested in the skeleton options + autoFillMinAda + -- We retrieve the official constitution script and attach it to each + -- proposal that requires it, if it's not empty + 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 + autoFillReferenceScripts + -- We attach the reward amount to withdrawals when applicable + autoFillWithdrawalAmounts + -- We balance the skeleton when requested in the skeleton option, and get + -- the associated fee, collateral inputs and return collateral user + ExtendedTxSkel finalTxSkel fee mCollaterals body <- viewTweak simple >>= balanceTxSkel + -- We log the adjusted skeleton + logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals + -- We generate the transaction asscoiated with the skeleton, and apply on it + -- the modifications from the skeleton options + signatories <- viewTweak txSkelSignatoriesL + let cardanoTx = P.Ledger.CardanoEmulatorEraTx $ txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories body + -- To run transaction validation we need a minimal ledger state + eLedgerState <- gets mcstLedgerState + -- We finally run the emulated validation. We update our internal state + -- based on the validation result, and throw an error if this fails. If at + -- some point we want to allows mockchain runs with validation errors, the + -- caller will need to catch those errors and do something with them. + newOutputs <- case Emulator.validateCardanoTx params eLedgerState cardanoTx of + -- In case of a phase 1 error, we give back the same index + (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 [err] + (newELedgerState, P.Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do + -- We update the emulated ledger state + modify' (set mcstLedgerStateL newELedgerState) + -- We remove the collateral utxos from our own stored outputs + forM_ colInputs $ modify' . removeOutput + -- We add the returned collateral to our outputs when it exists + case (mRetColOutput, Map.toList $ P.Ledger.getCardanoTxProducedReturnCollateral cardanoTx) of + (Nothing, []) -> return () + (Just retColOutput, [(txIn, _)]) -> modify' $ addOutput (P.Ledger.fromCardanoTxIn txIn) retColOutput + _ -> fail "Unreachable case when processing return collaterals, please report a bug at https://github.com/tweag/cooked-validators/issues" + -- We throw a mockchain error + throw $ MCEValidationError P.Ledger.Phase2 [err] + -- In case of success, we update the index with all inputs and outputs + -- contained in the transaction + (newELedgerState, P.Ledger.Success {}) -> do + -- We update the index with the utxos consumed and produced by the tx + modify' (set mcstLedgerStateL newELedgerState) + -- We retrieve the utxos created by the transaction + let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx + -- We combine them with their corresponding `TxSkelOut` + let newOutputs = zip utxos (txSkelOutputs finalTxSkel) + -- We add the news utxos to the state + forM_ newOutputs $ modify' . uncurry addOutput + -- And remove the old ones + forM_ (Map.toList $ txSkelInputs finalTxSkel) $ modify' . removeOutput . fst + -- We return the newly created outputs + return newOutputs + -- This is a theoretical unreachable case. Since we fail in Phase 2, it + -- means the transaction involved script, and thus we must have generated + -- collaterals. + (_, P.Ledger.FailPhase2 {}) + | Nothing <- mCollaterals -> + fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" + -- We increase the slot number + modify' $ over mcstLedgerStateL Emulator.nextSlot + -- We log the validated transaction + logEvent $ MCLogNewTx (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) + -- We return the validated transaction + return (cardanoTx, newOutputs) + +-- | Generates, balances and validates a transaction from a skeleton, and +-- returns the validated transaction, alongside the created UTxOs. +validateTxSkel :: (Member MockChainValidate effs) => TxSkel -> Sem effs (P.Ledger.CardanoTx, Utxos) + +-- | Same as `validateTxSkel`, but only returns the generated UTxOs +validateTxSkel' :: (Members '[MockChainReadChain, MockChainValidate] effs) => TxSkel -> Sem effs Utxos +validateTxSkel' = fmap snd . validateTxSkel + +-- | Same as `validateTxSkel`, but discards the returned transaction +validateTxSkel_ :: (Member MockChainValidate effs) => TxSkel -> Sem effs () +validateTxSkel_ = void . validateTxSkel diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index 2ca1a38de..951806cd6 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -14,11 +14,6 @@ module Cooked.MockChain.Effect.Write waitNMSFromSlotLowerBound, waitNMSFromSlotUpperBound, - -- * Sending `Cooked.Skeleton.TxSkel`s for validation - validateTxSkel, - validateTxSkel', - validateTxSkel_, - -- * Other operations setParams, setConstitutionScript, @@ -32,11 +27,7 @@ import Cardano.Api.Ledger qualified as Cardano import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Lens qualified as Lens import Control.Monad -import Cooked.MockChain.Automation.AutoFilling.Constitution import Cooked.MockChain.Automation.AutoFilling.MinAda -import Cooked.MockChain.Automation.AutoFilling.ReferenceScripts -import Cooked.MockChain.Automation.AutoFilling.Withdrawals -import Cooked.MockChain.Automation.Balancing import Cooked.MockChain.Automation.GenerateTx.Body import Cooked.MockChain.Automation.GenerateTx.Output import Cooked.MockChain.Common @@ -46,8 +37,6 @@ import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton -import Cooked.Tweak.Common -import Cooked.Tweak.Query import Data.Map.Strict qualified as Map import Ledger.Index qualified as P.Ledger import Ledger.Orphans () @@ -67,7 +56,6 @@ import Polysemy.State data MockChainWrite :: Effect where WaitNSlots :: Integer -> MockChainWrite m P.Ledger.Slot SetParams :: Emulator.Params -> MockChainWrite m () - ValidateTxSkel :: TxSkel -> MockChainWrite m (P.Ledger.CardanoTx, Utxos) SetConstitutionScript :: (ToVScript s) => s -> MockChainWrite m () ForceOutputs :: [TxSkelOut] -> MockChainWrite m Utxos @@ -82,8 +70,7 @@ runMockChainWrite :: Error MockChainError, MockChainLog, MockChainReadChain, - MockChainReadConf, - Fail + MockChainReadConf ] effs ) => @@ -159,80 +146,6 @@ runMockChainWrite = interpret $ \case modify' (over mcstOutputsL (<> outputsMap)) -- Finally, we return the created utxos return $ Map.toList (fst <$> outputsMap) - ValidateTxSkel skel -> fmap snd $ runTweak skel $ do - params <- gets mcstParams - -- We retrieve the current skeleton options - TxSkelOpts {..} <- viewTweak txSkelOptsL - -- We log the submission of the new skeleton - viewTweak simple >>= logEvent . MCLogSubmittedTxSkel - -- We ensure that the outputs have the required minimal amount of ada, when - -- requested in the skeleton options - autoFillMinAda - -- We retrieve the official constitution script and attach it to each - -- proposal that requires it, if it's not empty - 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 - autoFillReferenceScripts - -- We attach the reward amount to withdrawals when applicable - autoFillWithdrawalAmounts - -- We balance the skeleton when requested in the skeleton option, and get - -- the associated fee, collateral inputs and return collateral user - ExtendedTxSkel finalTxSkel fee mCollaterals body <- viewTweak simple >>= balanceTxSkel - -- We log the adjusted skeleton - logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals - -- We generate the transaction asscoiated with the skeleton, and apply on it - -- the modifications from the skeleton options - signatories <- viewTweak txSkelSignatoriesL - let cardanoTx = P.Ledger.CardanoEmulatorEraTx $ txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories body - -- To run transaction validation we need a minimal ledger state - eLedgerState <- gets mcstLedgerState - -- We finally run the emulated validation. We update our internal state - -- based on the validation result, and throw an error if this fails. If at - -- some point we want to allows mockchain runs with validation errors, the - -- caller will need to catch those errors and do something with them. - newOutputs <- case Emulator.validateCardanoTx params eLedgerState cardanoTx of - -- In case of a phase 1 error, we give back the same index - (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 [err] - (newELedgerState, P.Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do - -- We update the emulated ledger state - modify' (set mcstLedgerStateL newELedgerState) - -- We remove the collateral utxos from our own stored outputs - forM_ colInputs $ modify' . removeOutput - -- We add the returned collateral to our outputs when it exists - case (mRetColOutput, Map.toList $ P.Ledger.getCardanoTxProducedReturnCollateral cardanoTx) of - (Nothing, []) -> return () - (Just retColOutput, [(txIn, _)]) -> modify' $ addOutput (P.Ledger.fromCardanoTxIn txIn) retColOutput - _ -> fail "Unreachable case when processing return collaterals, please report a bug at https://github.com/tweag/cooked-validators/issues" - -- We throw a mockchain error - throw $ MCEValidationError P.Ledger.Phase2 [err] - -- In case of success, we update the index with all inputs and outputs - -- contained in the transaction - (newELedgerState, P.Ledger.Success {}) -> do - -- We update the index with the utxos consumed and produced by the tx - modify' (set mcstLedgerStateL newELedgerState) - -- We retrieve the utxos created by the transaction - let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx - -- We combine them with their corresponding `TxSkelOut` - let newOutputs = zip utxos (txSkelOutputs finalTxSkel) - -- We add the news utxos to the state - forM_ newOutputs $ modify' . uncurry addOutput - -- And remove the old ones - forM_ (Map.toList $ txSkelInputs finalTxSkel) $ modify' . removeOutput . fst - -- We return the newly created outputs - return newOutputs - -- This is a theoretical unreachable case. Since we fail in Phase 2, it - -- means the transaction involved script, and thus we must have generated - -- collaterals. - (_, P.Ledger.FailPhase2 {}) - | Nothing <- mCollaterals -> - fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" - -- We increase the slot number - modify' $ over mcstLedgerStateL Emulator.nextSlot - -- We log the validated transaction - logEvent $ MCLogNewTx (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) - -- We return the validated transaction - return (cardanoTx, newOutputs) -- | Waits a certain number of slots and returns the new slot waitNSlots :: (Member MockChainWrite effs) => Integer -> Sem effs P.Ledger.Slot @@ -259,18 +172,6 @@ waitNMSFromSlotLowerBound duration = currentMSRange >>= awaitEnclosingSlot . (+ waitNMSFromSlotUpperBound :: (Members '[MockChainReadChain, MockChainWrite, Fail] effs) => Integer -> Sem effs P.Ledger.Slot waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd --- | Generates, balances and validates a transaction from a skeleton, and --- returns the validated transaction, alongside the created UTxOs. -validateTxSkel :: (Member MockChainWrite effs) => TxSkel -> Sem effs (P.Ledger.CardanoTx, Utxos) - --- | Same as `validateTxSkel`, but only returns the generated UTxOs -validateTxSkel' :: (Members '[MockChainReadChain, MockChainWrite] effs) => TxSkel -> Sem effs Utxos -validateTxSkel' = fmap snd . validateTxSkel - --- | Same as `validateTxSkel`, but discards the returned transaction -validateTxSkel_ :: (Member MockChainWrite effs) => TxSkel -> Sem effs () -validateTxSkel_ = void . validateTxSkel - -- | Updates the current parameters setParams :: (Member MockChainWrite effs) => Emulator.Params -> Sem effs () diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index a82cd78f4..e1b861dd8 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -52,6 +52,7 @@ import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Misc import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Effect.Read.Conf +import Cooked.MockChain.Effect.Validation import Cooked.MockChain.Effect.Write import Cooked.MockChain.Run.Runnable import Cooked.MockChain.Run.Tweak @@ -69,7 +70,8 @@ import Polysemy.Writer -- | The most direct stack of effects to run a mockchain type DirectEffs = - '[ MockChainWrite, + '[ MockChainValidate, + MockChainWrite, MockChainReadChain, MockChainMisc, Fail @@ -92,14 +94,15 @@ instance RunnableMockChain DirectEffs where . runMockChainReadConfEmul . runMockChainReadChainEmul . runMockChainWrite - . insertAt @5 + . runMockChainValidate + . insertAt @6 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, State MockChainState, MockChainLog, Writer MockChainJournal ] - . insertAt @2 + . insertAt @3 @'[ MockChainReadConf ] @@ -124,6 +127,7 @@ type FullTweak a = TypedTweak FullTweakEffs a -- addition of all the lower level effects required to interpret it. type FullEffs = '[ ModifyGlobally (UntypedTweak FullTweakEffs), + MockChainValidate, MockChainWrite, ModifyLocally (UntypedTweak FullTweakEffs), State [Ltl (UntypedTweak FullTweakEffs)], @@ -158,7 +162,8 @@ instance RunnableMockChain FullEffs where . evalState [] . runModifyLocally . runMockChainWrite - . reinterpretMockChainWriteWithTweak @FullTweakEffs + . runMockChainValidate + . reinterpretMockChainValidateWithTweak @FullTweakEffs . runModifyGlobally -- | A stack of effects aimed at being used as modifications for a @@ -178,6 +183,7 @@ type ExtendedStagedTweak extraEff a = TypedTweak (ExtendedStagedTweakEffs extraE -- `ExtendedStagedTweakEffs` type ExtendedStagedEffs extraEff = '[ ModifyGlobally (UntypedTweak (ExtendedStagedTweakEffs extraEff)), + MockChainValidate, MockChainWrite, extraEff, MockChainMisc, @@ -212,19 +218,20 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . evalState [] . runModifyLocally . runMockChainWrite - . insertAt @8 + . runMockChainValidate + . insertAt @9 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, State MockChainState, MockChainLog, Writer MockChainJournal ] - . reinterpretMockChainWriteWithTweak @(ExtendedStagedTweakEffs extraEff) - . insertAt @6 + . reinterpretMockChainValidateWithTweak @(ExtendedStagedTweakEffs extraEff) + . insertAt @7 @'[ MockChainReadConf ] . runModifyGlobally - . insertAt @2 + . insertAt @3 @'[ ModifyLocally (UntypedTweak (ExtendedStagedTweakEffs extraEff)), State [Ltl (UntypedTweak (ExtendedStagedTweakEffs extraEff))] ] diff --git a/src/Cooked/MockChain/Run/Tweak.hs b/src/Cooked/MockChain/Run/Tweak.hs index bb88f19c8..0c5d520a6 100644 --- a/src/Cooked/MockChain/Run/Tweak.hs +++ b/src/Cooked/MockChain/Run/Tweak.hs @@ -2,7 +2,7 @@ -- of modifying transaction skeleton before sending them for validation. module Cooked.MockChain.Run.Tweak ( -- * Modifying mockchain runs using tweaks - reinterpretMockChainWriteWithTweak, + reinterpretMockChainValidateWithTweak, -- * Tweaks geared for 'Cooked.Skeleton.TxSkel' modifications TypedTweak, @@ -20,9 +20,8 @@ where import Control.Monad import Cooked.Ltl -import Cooked.MockChain.Effect.Write +import Cooked.MockChain.Effect.Validation import Cooked.Tweak.Common -import Data.Coerce import Polysemy import Polysemy.Internal import Polysemy.NonDet @@ -37,7 +36,7 @@ data UntypedTweak tweakEffs where -- | Applies a 'Tweak' to every step in a trace where it is applicable, -- branching at any such locations. The tweak must apply at least once. somewhere :: - (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + (Member (ModifyGlobally (UntypedTweak tweakEffs)) effs) => TypedTweak tweakEffs b -> Sem effs a -> Sem effs a @@ -46,7 +45,7 @@ somewhere = modifyLtl . ltlEventually . LtlAtom . UntypedTweak -- | Applies a 'Tweak' to every transaction in a given trace. Fails if the tweak -- fails anywhere in the trace. everywhere :: - (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + (Member (ModifyGlobally (UntypedTweak tweakEffs)) effs) => TypedTweak tweakEffs b -> Sem effs a -> Sem effs a @@ -55,7 +54,7 @@ everywhere = modifyLtl . ltlAlways . LtlAtom . UntypedTweak -- | Ensures a given 'Tweak' can never successfully be applied in a computation, -- and leaves the computation unchanged. nowhere :: - (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + (Member (ModifyGlobally (UntypedTweak tweakEffs)) effs) => TypedTweak tweakEffs b -> Sem effs a -> Sem effs a @@ -64,7 +63,7 @@ nowhere = modifyLtl . ltlNever . LtlAtom . UntypedTweak -- | Apply a given 'Tweak' at every location in a computation where it does not -- fail, which might never occur. whenAble :: - (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + (Member (ModifyGlobally (UntypedTweak tweakEffs)) effs) => TypedTweak tweakEffs b -> Sem effs a -> Sem effs a @@ -76,7 +75,7 @@ whenAble = modifyLtl . ltlWhenPossible . LtlAtom . UntypedTweak -- See also `Cooked.Tweak.Labels.labelled` to select transactions based on -- labels instead of their index. there :: - (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + (Member (ModifyGlobally (UntypedTweak tweakEffs)) effs) => Integer -> TypedTweak tweakEffs b -> Sem effs a -> @@ -94,15 +93,16 @@ there n = modifyLtl . ltlDelay n . LtlAtom . UntypedTweak -- given @arguments@. Then `withTweak` says "I want to modify the transaction -- returned by this endpoint in the following way". withTweak :: - (Members '[ModifyGlobally (UntypedTweak tweakEffs)] effs) => + (Member (ModifyGlobally (UntypedTweak tweakEffs)) effs) => Sem effs a -> TypedTweak tweakEffs b -> Sem effs a withTweak = flip (there 0) --- | Reinterpretes `MockChainWrite` in itself, when the `ModifyLocally` effect --- exists in the stack, applying the relevant modifications in the process. -reinterpretMockChainWriteWithTweak :: +-- | Reinterpretes `MockChainValidate` in itself, when the `ModifyLocally` +-- effect exists in the stack, applying the relevant modifications in the +-- process. +reinterpretMockChainValidateWithTweak :: forall tweakEffs effs a. ( Members '[ ModifyLocally (UntypedTweak tweakEffs), @@ -111,9 +111,9 @@ reinterpretMockChainWriteWithTweak :: effs, Subsume tweakEffs effs ) => - Sem (MockChainWrite : effs) a -> - Sem (MockChainWrite : effs) a -reinterpretMockChainWriteWithTweak = reinterpret @MockChainWrite $ \case + Sem (MockChainValidate : effs) a -> + Sem (MockChainValidate : effs) a +reinterpretMockChainValidateWithTweak = reinterpret @MockChainValidate $ \case ValidateTxSkel skel -> do requirements <- getRequirements let sumTweak :: TypedTweak tweakEffs () = @@ -130,4 +130,3 @@ reinterpretMockChainWriteWithTweak = reinterpret @MockChainWrite $ \case requirements newTxSkel <- raise $ subsume_ $ fst <$> runTweak skel sumTweak validateTxSkel newTxSkel - a -> send $ coerce a From 0cd56ab813093c606459e652a4991697c0fbb155 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Aug 2026 20:23:12 +0200 Subject: [PATCH 10/18] extracting automation pipeline --- cooked-validators.cabal | 1 + src/Cooked/MockChain.hs | 1 + src/Cooked/MockChain/Automation/Pipeline.hs | 83 +++++++++++++++++++++ src/Cooked/MockChain/Effect/Validation.hs | 44 +++-------- src/Cooked/MockChain/Effect/Write.hs | 4 +- 5 files changed, 96 insertions(+), 37 deletions(-) create mode 100644 src/Cooked/MockChain/Automation/Pipeline.hs diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 1e2e01d70..15215c98b 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -41,6 +41,7 @@ library Cooked.MockChain.Automation.GenerateTx.ReferenceInputs Cooked.MockChain.Automation.GenerateTx.Withdrawals Cooked.MockChain.Automation.GenerateTx.Witness + Cooked.MockChain.Automation.Pipeline Cooked.MockChain.Common Cooked.MockChain.Effect.Log Cooked.MockChain.Effect.Misc diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index 90cba3e76..b83765ae6 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -3,6 +3,7 @@ module Cooked.MockChain (module X) where import Cooked.MockChain.Automation.Balancing as X +import Cooked.MockChain.Automation.Pipeline as X import Cooked.MockChain.Common as X import Cooked.MockChain.Effect.Misc as X import Cooked.MockChain.Effect.Read.Chain as X diff --git a/src/Cooked/MockChain/Automation/Pipeline.hs b/src/Cooked/MockChain/Automation/Pipeline.hs new file mode 100644 index 000000000..231617d46 --- /dev/null +++ b/src/Cooked/MockChain/Automation/Pipeline.hs @@ -0,0 +1,83 @@ +module Cooked.MockChain.Automation.Pipeline + ( runAutomationPipeline, + ) +where + +import Cooked.MockChain.Automation.AutoFilling.Constitution +import Cooked.MockChain.Automation.AutoFilling.MinAda +import Cooked.MockChain.Automation.AutoFilling.ReferenceScripts +import Cooked.MockChain.Automation.AutoFilling.Withdrawals +import Cooked.MockChain.Automation.Balancing +import Cooked.MockChain.Automation.GenerateTx.Body +import Cooked.MockChain.Common +import Cooked.MockChain.Effect.Log +import Cooked.MockChain.Effect.Read.Chain +import Cooked.MockChain.Effect.Read.Conf +import Cooked.MockChain.Runtime.Error +import Cooked.MockChain.Runtime.State +import Cooked.Skeleton +import Cooked.Tweak.Common +import Cooked.Tweak.Query +import Cooked.Tweak.Update +import Ledger.Orphans () +import Ledger.Tx qualified as P.Ledger +import Optics.Core +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.State + +-- | This runs the full automation pipeline, in that order: +-- 1. autofill min ada on eligible outputs +-- 2. autofill constution on eligible proposals +-- 3. autofill reference inputs on eligible redeemers +-- 4. autofill amount on eligible withdrawals +-- 5. balance the skeleton according to the inner options +-- 6. generate the transaction associated with the balanced skeleton +-- It logs relevant events in the process, and returns the transaction. +runAutomationPipeline :: + ( Members + '[ State MockChainState, + Error P.Ledger.ToCardanoError, + Error MockChainError, + MockChainLog, + MockChainReadChain, + MockChainReadConf, + Fail + ] + effs + ) => + TxSkel -> + Sem effs (TxSkel, (P.Ledger.CardanoTx, Maybe Collaterals, Fee)) +runAutomationPipeline txSkel = runTweak txSkel $ do + -- We log the submission of the new skeleton + viewTweak simple >>= logEvent . MCLogSubmittedTxSkel + -- We retrieve the current skeleton options + TxSkelOpts {..} <- viewTweak txSkelOptsL + -- We ensure that the outputs have the required minimal amount of ada, when + -- requested in the skeleton options + autoFillMinAda + -- We retrieve the official constitution script and attach it to each + -- proposal that requires it, if it's not empty + 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 + autoFillReferenceScripts + -- We attach the reward amount to withdrawals when applicable + autoFillWithdrawalAmounts + -- We balance the skeleton when requested in the skeleton option, and get + -- the associated fee, collateral inputs and return collateral user + ExtendedTxSkel finalTxSkel fee mCollaterals body <- viewTweak simple >>= balanceTxSkel + -- We store the balanced skeleton + setTweak simple finalTxSkel + -- We log the balanced skeleton + logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals + -- We retrieve the extra signatories to add to the transaction + signatories <- viewTweak txSkelSignatoriesL + -- We generate the transaction asscoiated with the skeleton, and apply on it + -- the modifications from the skeleton options + return + ( P.Ledger.CardanoEmulatorEraTx $ txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories body, + mCollaterals, + fee + ) diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs index 09009c494..5bc3fc321 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -19,12 +19,7 @@ where import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad -import Cooked.MockChain.Automation.AutoFilling.Constitution -import Cooked.MockChain.Automation.AutoFilling.MinAda -import Cooked.MockChain.Automation.AutoFilling.ReferenceScripts -import Cooked.MockChain.Automation.AutoFilling.Withdrawals -import Cooked.MockChain.Automation.Balancing -import Cooked.MockChain.Automation.GenerateTx.Body +import Cooked.MockChain.Automation.Pipeline import Cooked.MockChain.Common import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Read.Chain @@ -32,8 +27,6 @@ import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton -import Cooked.Tweak.Common -import Cooked.Tweak.Query import Data.Map.Strict qualified as Map import Ledger.Index qualified as P.Ledger import Ledger.Orphans () @@ -69,34 +62,12 @@ runMockChainValidate :: Sem (MockChainValidate : effs) a -> Sem effs a runMockChainValidate = interpret $ \case - ValidateTxSkel skel -> fmap snd $ runTweak skel $ do - params <- gets mcstParams - -- We retrieve the current skeleton options - TxSkelOpts {..} <- viewTweak txSkelOptsL - -- We log the submission of the new skeleton - viewTweak simple >>= logEvent . MCLogSubmittedTxSkel - -- We ensure that the outputs have the required minimal amount of ada, when - -- requested in the skeleton options - autoFillMinAda - -- We retrieve the official constitution script and attach it to each - -- proposal that requires it, if it's not empty - 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 - autoFillReferenceScripts - -- We attach the reward amount to withdrawals when applicable - autoFillWithdrawalAmounts - -- We balance the skeleton when requested in the skeleton option, and get - -- the associated fee, collateral inputs and return collateral user - ExtendedTxSkel finalTxSkel fee mCollaterals body <- viewTweak simple >>= balanceTxSkel - -- We log the adjusted skeleton - logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals - -- We generate the transaction asscoiated with the skeleton, and apply on it - -- the modifications from the skeleton options - signatories <- viewTweak txSkelSignatoriesL - let cardanoTx = P.Ledger.CardanoEmulatorEraTx $ txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories body + ValidateTxSkel skel -> do + (finalTxSkel, (cardanoTx, mCollaterals, _)) <- runAutomationPipeline skel -- To run transaction validation we need a minimal ledger state eLedgerState <- gets mcstLedgerState + -- And the emulator params + params <- gets mcstParams -- We finally run the emulated validation. We update our internal state -- based on the validation result, and throw an error if this fails. If at -- some point we want to allows mockchain runs with validation errors, the @@ -140,7 +111,10 @@ runMockChainValidate = interpret $ \case -- We increase the slot number modify' $ over mcstLedgerStateL Emulator.nextSlot -- We log the validated transaction - logEvent $ MCLogNewTx (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) + logEvent $ + MCLogNewTx + (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) + (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) -- We return the validated transaction return (cardanoTx, newOutputs) diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index 951806cd6..ef8400a6d 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} --- | This module exposes primitives to update the current state of the --- blockchain, including by sending transactions for validation. +-- | This module exposes primitives to manually (and artificially) update the +-- current state of the blockchain. module Cooked.MockChain.Effect.Write ( -- * The `MockChainWrite` effect MockChainWrite (..), From bf2f707b420af07129a47b59f5d595701c443a97 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Aug 2026 23:07:49 +0200 Subject: [PATCH 11/18] sketching interp validate node --- src/Cooked/MockChain/Automation/Pipeline.hs | 5 +- src/Cooked/MockChain/Effect/Validation.hs | 92 +++++++++++++++++---- src/Cooked/MockChain/Run/Instances.hs | 6 +- 3 files changed, 79 insertions(+), 24 deletions(-) diff --git a/src/Cooked/MockChain/Automation/Pipeline.hs b/src/Cooked/MockChain/Automation/Pipeline.hs index 231617d46..64b327357 100644 --- a/src/Cooked/MockChain/Automation/Pipeline.hs +++ b/src/Cooked/MockChain/Automation/Pipeline.hs @@ -14,7 +14,6 @@ import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.State import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Query @@ -25,7 +24,6 @@ import Optics.Core import Polysemy import Polysemy.Error import Polysemy.Fail -import Polysemy.State -- | This runs the full automation pipeline, in that order: -- 1. autofill min ada on eligible outputs @@ -37,8 +35,7 @@ import Polysemy.State -- It logs relevant events in the process, and returns the transaction. runAutomationPipeline :: ( Members - '[ State MockChainState, - Error P.Ledger.ToCardanoError, + '[ Error P.Ledger.ToCardanoError, Error MockChainError, MockChainLog, MockChainReadChain, diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs index 5bc3fc321..7f5624b67 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -8,7 +8,8 @@ module Cooked.MockChain.Effect.Validation ( -- * The `MockChainValidate` effect MockChainValidate (..), - runMockChainValidate, + runMockChainValidateEmul, + runMockChainValidateNode, -- * Sending `Cooked.Skeleton.TxSkel`s for validation validateTxSkel, @@ -17,6 +18,7 @@ module Cooked.MockChain.Effect.Validation ) where +import Cardano.Api qualified as Cardano import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad import Cooked.MockChain.Automation.Pipeline @@ -36,6 +38,7 @@ import Optics.Core import Polysemy import Polysemy.Error import Polysemy.Fail +import Polysemy.Reader import Polysemy.State -- | An effect that offers the ability to send a `Cooked.Skeleton.TxSkel` for @@ -45,8 +48,20 @@ data MockChainValidate :: Effect where makeSem_ ''MockChainValidate --- | Interpretes the `MockChainValidate` effect -runMockChainValidate :: +-- | Generates, balances and validates a transaction from a skeleton, and +-- returns the validated transaction, alongside the created UTxOs. +validateTxSkel :: (Member MockChainValidate effs) => TxSkel -> Sem effs (P.Ledger.CardanoTx, Utxos) + +-- | Same as `validateTxSkel`, but only returns the generated UTxOs +validateTxSkel' :: (Members '[MockChainReadChain, MockChainValidate] effs) => TxSkel -> Sem effs Utxos +validateTxSkel' = fmap snd . validateTxSkel + +-- | Same as `validateTxSkel`, but discards the returned transaction +validateTxSkel_ :: (Member MockChainValidate effs) => TxSkel -> Sem effs () +validateTxSkel_ = void . validateTxSkel + +-- | Interprets the `MockChainValidate` effect on an emulator +runMockChainValidateEmul :: forall effs a. ( Members '[ State MockChainState, @@ -61,9 +76,9 @@ runMockChainValidate :: ) => Sem (MockChainValidate : effs) a -> Sem effs a -runMockChainValidate = interpret $ \case +runMockChainValidateEmul = interpret $ \case ValidateTxSkel skel -> do - (finalTxSkel, (cardanoTx, mCollaterals, _)) <- runAutomationPipeline skel + (finalTxSkel, (cardanoTx, mCollaterals, _fee)) <- runAutomationPipeline skel -- To run transaction validation we need a minimal ledger state eLedgerState <- gets mcstLedgerState -- And the emulator params @@ -77,7 +92,7 @@ runMockChainValidate = interpret $ \case (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 [err] (newELedgerState, P.Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do -- We update the emulated ledger state - modify' (set mcstLedgerStateL newELedgerState) + modify' $ set mcstLedgerStateL newELedgerState -- We remove the collateral utxos from our own stored outputs forM_ colInputs $ modify' . removeOutput -- We add the returned collateral to our outputs when it exists @@ -118,14 +133,57 @@ runMockChainValidate = interpret $ \case -- We return the validated transaction return (cardanoTx, newOutputs) --- | Generates, balances and validates a transaction from a skeleton, and --- returns the validated transaction, alongside the created UTxOs. -validateTxSkel :: (Member MockChainValidate effs) => TxSkel -> Sem effs (P.Ledger.CardanoTx, Utxos) - --- | Same as `validateTxSkel`, but only returns the generated UTxOs -validateTxSkel' :: (Members '[MockChainReadChain, MockChainValidate] effs) => TxSkel -> Sem effs Utxos -validateTxSkel' = fmap snd . validateTxSkel - --- | Same as `validateTxSkel`, but discards the returned transaction -validateTxSkel_ :: (Member MockChainValidate effs) => TxSkel -> Sem effs () -validateTxSkel_ = void . validateTxSkel +-- | Interprets the `MockChainValidate` effect by submitting the generated +-- transaction to a deployed node through a `Cardano.LocalNodeConnectInfo` +-- (socket path and network id) provided via a `Reader`, running in a stack +-- featuring @IO@ (via `Embed`). +-- +-- NOTE: this is a first sketch. It runs the same adjustment pipeline as the +-- emulator interpreter to obtain a balanced Cardano transaction, then submits it +-- to the node instead of validating it locally. Several aspects still need to be +-- decided (see the open questions raised alongside this implementation). +runMockChainValidateNode :: + forall effs a. + ( Members + '[ Embed IO, + Error P.Ledger.ToCardanoError, + Error MockChainError, + MockChainLog, + MockChainReadChain, + MockChainReadConf, + Reader Cardano.LocalNodeConnectInfo, + Fail + ] + effs + ) => + Sem (MockChainValidate : effs) a -> + Sem effs a +runMockChainValidateNode = interpret $ \case + ValidateTxSkel skel -> do + -- We run the whole adjustment pipeline to obtain a balanced Cardano + -- transaction, exactly like the emulator interpreter does. + (finalTxSkel, (cardanoTx, _mCollaterals, _fee)) <- runAutomationPipeline skel + -- We retrieve the local node connection info. + conn <- ask + -- We unwrap the underlying Cardano transaction to wrap it into a + -- 'Cardano.TxInMode' and submit it to the node. + let P.Ledger.CardanoEmulatorEraTx cTx = cardanoTx + result <- + embed $ + Cardano.submitTxToNodeLocal conn $ + Cardano.TxInMode Cardano.ShelleyBasedEraConway cTx + case result of + -- On success we mirror the emulator bookkeeping: we register the newly + -- created outputs and drop the consumed ones from our local state. + Cardano.SubmitSuccess -> do + let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx + newOutputs = zip utxos (txSkelOutputs finalTxSkel) + logEvent $ + MCLogNewTx + (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) + (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) + return (cardanoTx, newOutputs) + -- On rejection we currently surface the reason as a plain failure. This + -- should likely be turned into a dedicated 'MockChainError' constructor. + Cardano.SubmitFail reason -> + fail $ "Node rejected the transaction: " <> show reason diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index e1b861dd8..456b78b39 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -94,7 +94,7 @@ instance RunnableMockChain DirectEffs where . runMockChainReadConfEmul . runMockChainReadChainEmul . runMockChainWrite - . runMockChainValidate + . runMockChainValidateEmul . insertAt @6 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, @@ -162,7 +162,7 @@ instance RunnableMockChain FullEffs where . evalState [] . runModifyLocally . runMockChainWrite - . runMockChainValidate + . runMockChainValidateEmul . reinterpretMockChainValidateWithTweak @FullTweakEffs . runModifyGlobally @@ -218,7 +218,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . evalState [] . runModifyLocally . runMockChainWrite - . runMockChainValidate + . runMockChainValidateEmul . insertAt @9 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, From 0763dd1934fd29a271a5971b7ffdae8000fe9ae0 Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 6 Aug 2026 00:55:00 +0200 Subject: [PATCH 12/18] splitting MockChainState into EmulatorState and ChainIndex --- CHANGELOG.md | 10 ++ src/Cooked/MockChain/Effect/Read/Chain.hs | 20 ++-- src/Cooked/MockChain/Effect/Read/Conf.hs | 12 +- src/Cooked/MockChain/Effect/Validation.hs | 13 ++- src/Cooked/MockChain/Effect/Write.hs | 19 ++-- src/Cooked/MockChain/Run/Instances.hs | 27 +++-- src/Cooked/MockChain/Run/Runnable.hs | 26 +++-- src/Cooked/MockChain/Runtime/State.hs | 130 +++++++++++++--------- src/Cooked/MockChain/Testing.hs | 24 ++-- tests/Spec/Slot.hs | 4 +- 10 files changed, 170 insertions(+), 115 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9a3d57888..98b330600 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,16 @@ ### Changed +- The former `MockChainState` has been split into two independent records, each + backed by its own state monad: `EmulatorState` (the emulator `Params` and + `EmulatedLedgerState`, only relevant when running against the emulated ledger) + and `ChainIndex` (the map of known outputs and the constitution script, which + is backend-agnostic and also meaningful for the node backend). Accordingly, + `mcstToUtxoState` is now `chainIndexToUtxoState`, the `mcst*L` optics are + replaced by `emulatorState*L`/`chainIndex*L`, `MockChainConf` now carries + `mccInitialEmulatorState` and `mccInitialChainIndex`, and + `RunnableMockChain.runMockChain` takes an `EmulatorState` and a `ChainIndex`. + ### Removed ### Fixed diff --git a/src/Cooked/MockChain/Effect/Read/Chain.hs b/src/Cooked/MockChain/Effect/Read/Chain.hs index e58f14d22..19aad6245 100644 --- a/src/Cooked/MockChain/Effect/Read/Chain.hs +++ b/src/Cooked/MockChain/Effect/Read/Chain.hs @@ -252,11 +252,13 @@ getCurrentReward :: c -> Sem effs (Maybe Api.Lovelace) --- | The interpretation for read-only effect with a stored 'MockChainState' +-- | The interpretation for read-only effect with a stored 'EmulatorState' and +-- 'ChainIndex' runMockChainReadChainEmul :: forall effs a. ( Members - '[ State MockChainState, + '[ State EmulatorState, + State ChainIndex, Error P.Ledger.ToCardanoError, Error MockChainError, Fail @@ -267,15 +269,15 @@ runMockChainReadChainEmul :: Sem effs a runMockChainReadChainEmul = interpret $ \case TxSkelOutByRef oRef -> do - res <- gets $ Map.lookup oRef . mcstOutputs + res <- gets $ Map.lookup oRef . chainIndexOutputs case res of Just (txSkelOut, True) -> return txSkelOut _ -> throw $ MCEUnknownOutRef oRef AllUtxos -> fetchUtxos $ const True UtxosAt (Script.toAddress -> addr) -> fetchUtxos $ (== addr) . Script.toAddress - CurrentSlot -> gets $ view $ mcstLedgerStateL % to Emulator.getSlot + CurrentSlot -> gets $ view $ emulatorStateLedgerStateL % to Emulator.getSlot SlotToMSRange slot -> do - slotConfig <- gets $ Emulator.pSlotConfig . mcstParams + slotConfig <- gets $ Emulator.pSlotConfig . emulatorStateParams case Emulator.slotToPOSIXTimeRange slotConfig slot of Api.Interval (Api.LowerBound (Api.Finite l) leftclosed) @@ -285,13 +287,13 @@ runMockChainReadChainEmul = interpret $ \case if rightclosed then r else r - 1 ) _ -> fail "Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues" - GetEnclosingSlot t -> gets $ (`Emulator.posixTimeToEnclosingSlot` t) . Emulator.pSlotConfig . mcstParams - GetConstitutionScript -> gets $ view mcstConstitutionL + GetEnclosingSlot t -> gets $ (`Emulator.posixTimeToEnclosingSlot` t) . Emulator.pSlotConfig . emulatorStateParams + GetConstitutionScript -> gets $ view chainIndexConstitutionL GetCurrentReward (Script.toCredential -> cred) -> do stakeCredential <- toStakeCredential cred gets $ preview $ - mcstLedgerStateL + emulatorStateLedgerStateL % to (Emulator.getReward stakeCredential) % _Just % to coerce @@ -299,7 +301,7 @@ runMockChainReadChainEmul = interpret $ \case fetchUtxos decide = gets $ toListOf $ - mcstOutputsL + chainIndexOutputsL % to Map.toList % traversed % filtered (snd . snd) diff --git a/src/Cooked/MockChain/Effect/Read/Conf.hs b/src/Cooked/MockChain/Effect/Read/Conf.hs index 06a6b69d8..847057973 100644 --- a/src/Cooked/MockChain/Effect/Read/Conf.hs +++ b/src/Cooked/MockChain/Effect/Read/Conf.hs @@ -63,16 +63,16 @@ data MockChainReadConf :: Effect where makeSem_ ''MockChainReadConf -- | The interpretation for the configuration effect with a stored --- 'MockChainState' +-- 'EmulatorState' runMockChainReadConfEmul :: - (Member (State MockChainState) effs) => + (Member (State EmulatorState) effs) => Sem (MockChainReadConf : effs) a -> Sem effs a runMockChainReadConfEmul = interpret $ \case - GetParams -> gets $ Emulator.pEmulatorPParams . mcstParams - GetNetworkId -> gets $ Emulator.pNetworkId . mcstParams - GetEraHistory -> gets $ Emulator.emulatorEraHistory . mcstParams - GetSystemStart -> gets $ Shelley.systemStart . Emulator.emulatorGlobals . mcstParams + GetParams -> gets $ Emulator.pEmulatorPParams . emulatorStateParams + GetNetworkId -> gets $ Emulator.pNetworkId . emulatorStateParams + GetEraHistory -> gets $ Emulator.emulatorEraHistory . emulatorStateParams + GetSystemStart -> gets $ Shelley.systemStart . Emulator.emulatorGlobals . emulatorStateParams -- | Interpret the `MockChainReadConf` effect by talking to a deployed node -- through a `Cardano.LocalNodeConnectInfo` (socket path and network id) provided diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs index 7f5624b67..8fefa3871 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -64,7 +64,8 @@ validateTxSkel_ = void . validateTxSkel runMockChainValidateEmul :: forall effs a. ( Members - '[ State MockChainState, + '[ State EmulatorState, + State ChainIndex, Error P.Ledger.ToCardanoError, Error MockChainError, MockChainLog, @@ -80,9 +81,9 @@ runMockChainValidateEmul = interpret $ \case ValidateTxSkel skel -> do (finalTxSkel, (cardanoTx, mCollaterals, _fee)) <- runAutomationPipeline skel -- To run transaction validation we need a minimal ledger state - eLedgerState <- gets mcstLedgerState + eLedgerState <- gets emulatorStateLedgerState -- And the emulator params - params <- gets mcstParams + params <- gets emulatorStateParams -- We finally run the emulated validation. We update our internal state -- based on the validation result, and throw an error if this fails. If at -- some point we want to allows mockchain runs with validation errors, the @@ -92,7 +93,7 @@ runMockChainValidateEmul = interpret $ \case (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 [err] (newELedgerState, P.Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do -- We update the emulated ledger state - modify' $ set mcstLedgerStateL newELedgerState + modify' $ set emulatorStateLedgerStateL newELedgerState -- We remove the collateral utxos from our own stored outputs forM_ colInputs $ modify' . removeOutput -- We add the returned collateral to our outputs when it exists @@ -106,7 +107,7 @@ runMockChainValidateEmul = interpret $ \case -- contained in the transaction (newELedgerState, P.Ledger.Success {}) -> do -- We update the index with the utxos consumed and produced by the tx - modify' (set mcstLedgerStateL newELedgerState) + modify' (set emulatorStateLedgerStateL newELedgerState) -- We retrieve the utxos created by the transaction let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx -- We combine them with their corresponding `TxSkelOut` @@ -124,7 +125,7 @@ runMockChainValidateEmul = interpret $ \case | Nothing <- mCollaterals -> fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" -- We increase the slot number - modify' $ over mcstLedgerStateL Emulator.nextSlot + modify' $ over emulatorStateLedgerStateL Emulator.nextSlot -- We log the validated transaction logEvent $ MCLogNewTx diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index ef8400a6d..c9591ff1f 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -65,7 +65,8 @@ makeSem_ ''MockChainWrite runMockChainWrite :: forall effs a. ( Members - '[ State MockChainState, + '[ State EmulatorState, + State ChainIndex, Error P.Ledger.ToCardanoError, Error MockChainError, MockChainLog, @@ -78,21 +79,21 @@ runMockChainWrite :: Sem effs a runMockChainWrite = interpret $ \case SetParams params -> do - modify $ set mcstParamsL params - modify $ over mcstLedgerStateL $ Emulator.updateStateParams params + modify $ set emulatorStateParamsL params + modify $ over emulatorStateLedgerStateL $ Emulator.updateStateParams params WaitNSlots n -> do - cs <- gets (Emulator.getSlot . mcstLedgerState) + cs <- gets (Emulator.getSlot . emulatorStateLedgerState) if | n == 0 -> return cs | n > 0 -> do let newSlot = cs + fromIntegral n - modify' (over mcstLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot) + modify' (over emulatorStateLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot) return newSlot | otherwise -> throw $ MCEPastSlot cs (cs + fromIntegral n) SetConstitutionScript (toVScript -> cScript) -> do - modify' (mcstConstitutionL ?~ cScript) + modify' (chainIndexConstitutionL ?~ cScript) modify' $ - over mcstLedgerStateL $ + over emulatorStateLedgerStateL $ Lens.set Emulator.elsConstitutionScriptL $ (Cardano.SJust . Cardano.toShelleyScriptHash . Script.toCardanoScriptHash) cScript @@ -134,7 +135,7 @@ runMockChainWrite = interpret $ \case outputsMinAda -- We update the index, which effectively receives the new utxos modify' - ( over mcstLedgerStateL $ + ( over emulatorStateLedgerStateL $ Lens.over Emulator.elsUtxoL ( P.Ledger.fromPlutusIndex @@ -143,7 +144,7 @@ runMockChainWrite = interpret $ \case ) ) -- We update our internal map by adding the new outputs - modify' (over mcstOutputsL (<> outputsMap)) + modify' (over chainIndexOutputsL (<> outputsMap)) -- Finally, we return the created utxos return $ Map.toList (fst <$> outputsMap) diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index 456b78b39..6c57638b3 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -81,12 +81,13 @@ type DirectEffs = type DirectMockChain a = Sem DirectEffs a instance RunnableMockChain DirectEffs where - runMockChain mcst = + runMockChain emInit ciInit = (: []) . run . runWriter . runMockChainLog fromLogEntry - . runState mcst + . runState ciInit + . runState emInit . runError . runToCardanoErrorInMockChainError . runFailInMockChainError @@ -98,7 +99,8 @@ instance RunnableMockChain DirectEffs where . insertAt @6 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, - State MockChainState, + State EmulatorState, + State ChainIndex, MockChainLog, Writer MockChainJournal ] @@ -115,7 +117,8 @@ type FullTweakEffs = Fail, Error P.Ledger.ToCardanoError, Error MockChainError, - State MockChainState, + State EmulatorState, + State ChainIndex, MockChainLog, Writer MockChainJournal ] @@ -137,7 +140,8 @@ type FullEffs = Fail, Error P.Ledger.ToCardanoError, Error MockChainError, - State MockChainState, + State EmulatorState, + State ChainIndex, MockChainLog, Writer MockChainJournal, NonDet @@ -147,12 +151,13 @@ type FullEffs = type FullMockChain a = Sem FullEffs a instance RunnableMockChain FullEffs where - runMockChain mcst = + runMockChain emInit ciInit = run . runNonDet . runWriter . runMockChainLog fromLogEntry - . runState mcst + . runState ciInit + . runState emInit . runError . runToCardanoErrorInMockChainError . runFailInMockChainError @@ -202,12 +207,13 @@ class InterpretAlone eff where runInterpretAlone :: Sem (eff : effs) a -> Sem effs a instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extraEff) where - runMockChain mcst = + runMockChain emInit ciInit = run . runNonDet . runWriter . runMockChainLog fromLogEntry - . runState mcst + . runState ciInit + . runState emInit . runError . runToCardanoErrorInMockChainError . runFailInMockChainError @@ -222,7 +228,8 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . insertAt @9 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, - State MockChainState, + State EmulatorState, + State ChainIndex, MockChainLog, Writer MockChainJournal ] diff --git a/src/Cooked/MockChain/Run/Runnable.hs b/src/Cooked/MockChain/Run/Runnable.hs index 6f7667abf..46bed059e 100644 --- a/src/Cooked/MockChain/Run/Runnable.hs +++ b/src/Cooked/MockChain/Run/Runnable.hs @@ -72,7 +72,7 @@ distributionFromList = foldl' (\x (user, values) -> x <> map (receives user . Va -- | Raw return type of running a mockchain type RawMockChainReturn a = - (MockChainJournal, (MockChainState, Either MockChainError a)) + (MockChainJournal, (ChainIndex, (EmulatorState, Either MockChainError a))) -- | The returned type when running a mockchain. This is both a reorganizing and -- filtering of the natural returned type `RawMockChainReturn`. @@ -96,14 +96,16 @@ type FunOnMockChainResult a b = RawMockChainReturn a -> b -- | Building a `MockChainReturn` from a `RawMockChainReturn` unRawMockChainReturn :: FunOnMockChainResult a (MockChainReturn a) -unRawMockChainReturn (journal, (st, val)) = - MockChainReturn val (mcstOutputs st) (mcstToUtxoState st) journal +unRawMockChainReturn (journal, (chainIndex, (_emulatorState, val))) = + MockChainReturn val (chainIndexOutputs chainIndex) (chainIndexToUtxoState chainIndex) journal -- | Configuration from which to run a mockchain data MockChainConf a b where MockChainConf :: - { -- | The initial state from which to run the mockchain - mccInitialState :: MockChainState, + { -- | The initial emulator state from which to run the mockchain + mccInitialEmulatorState :: EmulatorState, + -- | The initial chain index from which to run the mockchain + mccInitialChainIndex :: ChainIndex, -- | The initial payments to issue in the run mccInitialDistribution :: InitialDistribution, -- | The function to apply on the results of the run @@ -111,16 +113,16 @@ data MockChainConf a b where } -> MockChainConf a b --- | The default `MockChainConf`, which uses the default initial state and +-- | The default `MockChainConf`, which uses the default initial states and -- initial distribution, and returns a refined `MockChainReturn` mockChainConfTemplate :: MockChainConf a (MockChainReturn a) -mockChainConfTemplate = MockChainConf def def unRawMockChainReturn +mockChainConfTemplate = MockChainConf def def def unRawMockChainReturn -- | The class of effects that represent a mockchain run class RunnableMockChain effs where - -- | Runs a computation from an initial `MockChainState`, while returning a - -- list of `RawMockChainReturn` - runMockChain :: MockChainState -> Sem effs a -> [RawMockChainReturn a] + -- | Runs a computation from an initial `EmulatorState` and `ChainIndex`, + -- while returning a list of `RawMockChainReturn` + runMockChain :: EmulatorState -> ChainIndex -> Sem effs a -> [RawMockChainReturn a] -- | Runs a `RunnableMockChain` from an initial `MockChainConf` runMockChainFromConf :: @@ -130,9 +132,9 @@ runMockChainFromConf :: MockChainConf a b -> Sem effs a -> [b] -runMockChainFromConf (MockChainConf initState initDist funOnResult) currentRun = +runMockChainFromConf (MockChainConf emInitState ciInitState initDist funOnResult) currentRun = fmap funOnResult $ - runMockChain initState $ + runMockChain emInitState ciInitState $ forceOutputs initDist >> currentRun -- | Runs a `RunnableMockChain` from an initial distribution diff --git a/src/Cooked/MockChain/Runtime/State.hs b/src/Cooked/MockChain/Runtime/State.hs index 9c64782e8..b1a881170 100644 --- a/src/Cooked/MockChain/Runtime/State.hs +++ b/src/Cooked/MockChain/Runtime/State.hs @@ -1,9 +1,18 @@ --- | This module exposes the internal state in which our direct simulation is --- run (`MockChainState`), as well as a restricted and simplified version --- (`UtxoState`). The latter only consists of Utxos with a focus on who owns --- those Utxos. You can see this as having some sort of an "account" view of the --- ledger state, which typically does not exist in Cardano. This is useful for --- two reasons: +-- | This module exposes the two independent pieces of state in which our direct +-- simulation is run: +-- +-- - `EmulatorState`, which gathers the emulator-specific data (the emulator +-- `Emulator.Params` and the `Emulator.EmulatedLedgerState`). This is only +-- relevant when running against the emulated ledger. +-- +-- - `ChainIndex`, which gathers the backend-agnostic data (the map of known +-- outputs and the current constitution script). This piece of state is also +-- meaningful for the node backend, which keeps its own local `ChainIndex`. +-- +-- It also exposes a restricted and simplified view (`UtxoState`). The latter +-- only consists of Utxos with a focus on who owns those Utxos. You can see this +-- as having some sort of an "account" view of the ledger state, which typically +-- does not exist in Cardano. This is useful for two reasons: -- -- - For printing purposes, where it is much more convenient to see the available -- assets as "who owns what" rather than as a set of mixed Utxos. @@ -12,19 +21,22 @@ -- needed. For instance, properties such as "does Alice indeed owns 3 XXX -- tokens at the end of this run?" become much easier to express. module Cooked.MockChain.Runtime.State - ( -- * `MockChainState` and associated optics - MockChainState (..), - mcstParamsL, - mcstLedgerStateL, - mcstOutputsL, - mcstConstitutionL, - mcstMOutputL, - - -- * Helpers to add or remove outputs from a `MockChainState` + ( -- * `EmulatorState` and associated optics + EmulatorState (..), + emulatorStateParamsL, + emulatorStateLedgerStateL, + + -- * `ChainIndex` and associated optics + ChainIndex (..), + chainIndexOutputsL, + chainIndexConstitutionL, + chainIndexMOutputL, + + -- * Helpers to add or remove outputs from a `ChainIndex` addOutput, removeOutput, - -- * `UtxoState`: A simplified, address-focused view on a `MockChainState` + -- * `UtxoState`: A simplified, address-focused view on a `ChainIndex` UtxoPayloadDatum (..), utxoPayloadDatumKindAT, utxoPayloadDatumTypedAT, @@ -43,8 +55,8 @@ module Cooked.MockChain.Runtime.State -- * Querying the assets owned by a given address holdsInState, - -- * Transforming a `MockChainState` into an `UtxoState` - mcstToUtxoState, + -- * Transforming a `ChainIndex` into an `UtxoState` + chainIndexToUtxoState, ) where @@ -63,50 +75,64 @@ import Plutus.Script.Utils.Address qualified as Script import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api --- | The state used to run the simulation in 'Cooked.MockChain.Direct' -data MockChainState where - MockChainState :: +-- | The emulator-specific state used to run the simulation in +-- 'Cooked.MockChain.Direct'. It only makes sense when running against the +-- emulated ledger. +data EmulatorState where + EmulatorState :: { -- | The parameters of the emulated blockchain - mcstParams :: Emulator.Params, + emulatorStateParams :: Emulator.Params, -- | The ledger state of the emulated blockchain - mcstLedgerState :: Emulator.EmulatedLedgerState, - -- | Associates to each 'Api.TxOutRef' the 'TxSkelOut' that produced it, + emulatorStateLedgerState :: Emulator.EmulatedLedgerState + } -> + EmulatorState + deriving (Show) + +-- | Focuses on the parameters of an 'EmulatorState' +makeLensesFor [("emulatorStateParams", "emulatorStateParamsL")] ''EmulatorState + +-- | Focuses on the ledger state of an 'EmulatorState' +makeLensesFor [("emulatorStateLedgerState", "emulatorStateLedgerStateL")] ''EmulatorState + +instance Default EmulatorState where + def = EmulatorState def (Emulator.initialState def) + +-- | The backend-agnostic state used to run the simulation. It gathers the map +-- of known outputs and the current constitution script. It is also meaningful +-- for the node backend, which keeps its own local 'ChainIndex'. +data ChainIndex where + ChainIndex :: + { -- | 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), + chainIndexOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), -- | The constitution script to be used with proposals - mcstConstitution :: Maybe VScript + chainIndexConstitution :: Maybe VScript } -> - MockChainState + ChainIndex deriving (Show) --- | Focuses on the parameters of a 'MockChainState' -makeLensesFor [("mcstParams", "mcstParamsL")] ''MockChainState - --- | Focuses on the ledger state of a 'MockChainState' -makeLensesFor [("mcstLedgerState", "mcstLedgerStateL")] ''MockChainState - --- | Focuses on the outputs of a 'MockChainState' -makeLensesFor [("mcstOutputs", "mcstOutputsL")] ''MockChainState +-- | Focuses on the outputs of a 'ChainIndex' +makeLensesFor [("chainIndexOutputs", "chainIndexOutputsL")] ''ChainIndex --- | Focuses on the constitution script of a 'MockChainState' -makeLensesFor [("mcstConstitution", "mcstConstitutionL")] ''MockChainState +-- | Focuses on the constitution script of a 'ChainIndex' +makeLensesFor [("chainIndexConstitution", "chainIndexConstitutionL")] ''ChainIndex -instance Default MockChainState where - def = MockChainState def (Emulator.initialState def) Map.empty Nothing +instance Default ChainIndex where + def = ChainIndex Map.empty Nothing --- | Accesses a given available Utxo from a `MockChainState` -mcstMOutputL :: Api.TxOutRef -> Lens' MockChainState (Maybe TxSkelOut) -mcstMOutputL oRef = mcstOutputsL % at oRef % iso (fmap fst) (fmap (,True)) +-- | Accesses a given available Utxo from a `ChainIndex` +chainIndexMOutputL :: Api.TxOutRef -> Lens' ChainIndex (Maybe TxSkelOut) +chainIndexMOutputL oRef = chainIndexOutputsL % at oRef % iso (fmap fst) (fmap (,True)) --- | Stores an output in a 'MockChainState' -addOutput :: Api.TxOutRef -> TxSkelOut -> MockChainState -> MockChainState -addOutput oRef = set (mcstMOutputL oRef) . Just +-- | Stores an output in a 'ChainIndex' +addOutput :: Api.TxOutRef -> TxSkelOut -> ChainIndex -> ChainIndex +addOutput oRef = set (chainIndexMOutputL oRef) . Just --- | Removes an output from the 'MockChainState'. This does not actually remove +-- | Removes an output from the 'ChainIndex'. This does not actually remove -- it from the map, but instead marks its availability to @False@ -removeOutput :: Api.TxOutRef -> MockChainState -> MockChainState -removeOutput oRef = set (mcstOutputsL % at oRef % _Just % _2) False +removeOutput :: Api.TxOutRef -> ChainIndex -> ChainIndex +removeOutput oRef = set (chainIndexOutputsL % at oRef % _Just % _2) False -- | A simplified version of a 'Cooked.Skeleton.Datum.TxSkelOutDatum' which only -- stores the actual datum and whether it is hashed (@True@) or inline @@ -260,10 +286,10 @@ holdsInState (Script.toAddress -> address) = maybe mempty utxoPayloadSetTotal . utxoPayloadSetTotal :: UtxoPayloadSet -> Api.Value utxoPayloadSetTotal = foldOf (utxoPayloadSetListI % folded % utxoPayloadValueL) --- | Builds a 'UtxoState' from a 'MockChainState' -mcstToUtxoState :: MockChainState -> UtxoState -mcstToUtxoState = - List.foldl' extractPayload mempty . Map.toList . mcstOutputs +-- | Builds a 'UtxoState' from a 'ChainIndex' +chainIndexToUtxoState :: ChainIndex -> UtxoState +chainIndexToUtxoState = + List.foldl' extractPayload mempty . Map.toList . chainIndexOutputs where extractPayload :: UtxoState -> (Api.TxOutRef, (TxSkelOut, Bool)) -> UtxoState extractPayload utxoState (txOutRef, (txSkelOut, bool)) = diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index c1ac78abc..86c3a8e3d 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -291,7 +291,7 @@ type LogProp prop = PrettyCookedOpts -> [MockChainLogEntry] -> prop type StateProp prop = PrettyCookedOpts -> UtxoState -> prop -- | Type of trace runners -type Runner effs a b = MockChainState -> InitialDistribution -> Sem effs a -> [MockChainReturn b] +type Runner effs a b = EmulatorState -> ChainIndex -> InitialDistribution -> Sem effs a -> [MockChainReturn b] -- | Data structure to test a mockchain trace. @a@ is the return typed of the -- tested trace, @prop@ is the domain in which the properties live. This is not @@ -301,8 +301,10 @@ data Test effs a b prop = Test testTrace :: Sem effs a, -- | The runner of the trace, possibly changing the return type testRunner :: Runner effs a b, - -- | The initial state from which the trace should be run - testInitState :: MockChainState, + -- | The initial emulator state from which the trace should be run + testInitEmulatorState :: EmulatorState, + -- | The initial chain index from which the trace should be run + testInitChainIndex :: ChainIndex, -- | The initial distribution from which the trace should be run testInitDist :: InitialDistribution, -- | The requirement on the number of results @@ -330,7 +332,7 @@ testToProp :: Test effs a b prop -> prop testToProp Test {..} = - let results = testRunner testInitState testInitDist testTrace + let results = testRunner testInitEmulatorState testInitChainIndex testInitDist testTrace in testSizeProp (toInteger (length results)) .&&. testAll ( \ret@(MockChainReturn outcome _ state (MockChainJournal mcLog names _ assertions)) -> @@ -405,7 +407,8 @@ mustSucceedTest' runner trace = Test { testTrace = trace, testRunner = runner, - testInitState = def, + testInitEmulatorState = def, + testInitChainIndex = def, testInitDist = def, testSizeProp = isAtLeastOfSize 1, testFailureProp = \_ _ _ _ -> testFailureMsg "💀 Unexpected failure!", @@ -421,8 +424,8 @@ mustSucceedTest :: ) => Sem effs a -> Test effs a a prop -mustSucceedTest = mustSucceedTest' $ \initState initDist -> - runMockChainFromConf $ MockChainConf initState initDist unRawMockChainReturn +mustSucceedTest = mustSucceedTest' $ \emInitState ciInitState initDist -> + runMockChainFromConf $ MockChainConf emInitState ciInitState initDist unRawMockChainReturn -- | A test template which expects a failure from a trace. See -- `mustSucceedTest'` for more information on its intended usage. @@ -435,7 +438,8 @@ mustFailTest' runner trace = Test { testTrace = trace, testRunner = runner, - testInitState = def, + testInitEmulatorState = def, + testInitChainIndex = def, testInitDist = def, testSizeProp = const testSuccess, testFailureProp = \_ _ _ _ -> testSuccess, @@ -451,8 +455,8 @@ mustFailTest :: ) => Sem effs a -> Test effs a a prop -mustFailTest = mustFailTest' $ \initState initDist -> - runMockChainFromConf $ MockChainConf initState initDist unRawMockChainReturn +mustFailTest = mustFailTest' $ \emInitState ciInitState initDist -> + runMockChainFromConf $ MockChainConf emInitState ciInitState initDist unRawMockChainReturn -- * Appending elements (in particular requirements) to existing tests diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index b2870cbdc..1d88ef29a 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -17,7 +17,8 @@ import Test.Tasty.QuickCheck runSlot :: Sem '[ MockChainReadChain, - State MockChainState, + State EmulatorState, + State ChainIndex, Fail, Error P.Ledger.ToCardanoError, Error MockChainError @@ -30,6 +31,7 @@ runSlot = . runToCardanoErrorInMockChainError . runFailInMockChainError . evalState def + . evalState def . runMockChainReadChainEmul tests :: TestTree From 0085e8d5fa765b52410d357903a5bcbe9a91e1dd Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 6 Aug 2026 01:36:37 +0200 Subject: [PATCH 13/18] upgrading the interpretation of GetConstitution with the storing of the script --- src/Cooked/MockChain/Effect/Read/Chain.hs | 46 +++++++++++++++-------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/src/Cooked/MockChain/Effect/Read/Chain.hs b/src/Cooked/MockChain/Effect/Read/Chain.hs index 19aad6245..ee2f61ac5 100644 --- a/src/Cooked/MockChain/Effect/Read/Chain.hs +++ b/src/Cooked/MockChain/Effect/Read/Chain.hs @@ -324,7 +324,8 @@ runMockChainReadChainNode :: Error Cardano.PastHorizonException, Error P.Ledger.ToCardanoError, Error MockChainError, - Reader Cardano.LocalNodeConnectInfo + Reader Cardano.LocalNodeConnectInfo, + State ChainIndex ] effs ) => @@ -357,19 +358,30 @@ runMockChainReadChainNode = interpret $ \case -- This case is reduced to [] as there can never be more than one UTxO -- with a given 'Api.TxOutRef'. _ -> throw $ MCEUnknownOutRef oRef - -- The constitution query only exposes the guardrail script /hash/, never the - -- script bytes themselves. To recover the full script, we rely on the on-chain - -- convention (used on the public networks) that the guardrail script is posted - -- as a reference script at its own enterprise script address. We therefore - -- derive that address from the queried hash, list the UTxOs sitting there, and - -- return the reference script whose hash matches the constitution's. When no - -- such reference script is present (e.g. on a private network where nobody - -- posted it), we return 'Nothing'. GetConstitutionScript -> do + -- We retrieve the official optional script hash of the current constitution Cardano.Constitution _ mScriptHash <- queryAndHandleErrors $ Cardano.queryConstitution Cardano.ConwayEraOnwardsConway + -- We retrieve the optional constitution already stored in the chain index + mStoredConstitution <- gets chainIndexConstitution + -- We inspect the current option constitution script hash case mScriptHash of - SNothing -> return Nothing + -- There is no official constitution (should not happen). We just set our + -- own constitution to @Nothing@ accordingly. + SNothing -> do + modify' $ set chainIndexConstitutionL Nothing + return Nothing + -- There is an official constitution, and it matches the stored one, which + -- we directly return. + SJust (Cardano.ScriptHash -> scriptHash) + | Just storedConstitution <- mStoredConstitution, + Script.toScriptHash scriptHash == Script.toScriptHash storedConstitution -> + return $ Just storedConstitution + -- There is an official constitution, and it does not match the stored one + -- (it has changed, or it's the first time it's been queried). We fetch + -- the actual constitution from a reference script at its own address, + -- where it should live, according to a governance convention. We store + -- the script we find there after verifying its hash, and return it. SJust (Cardano.ScriptHash -> scriptHash) -> do networkId <- getNetworkId utxo <- @@ -381,12 +393,14 @@ runMockChainReadChainNode = interpret $ \case networkId (Cardano.PaymentCredentialByScript scriptHash) Cardano.NoStakeAddress - return $ - listToMaybe $ - [ script - | (_, preview txSkelOutReferenceScriptAT -> Just script) <- utxo, - Script.toScriptHash script == Script.toScriptHash scriptHash - ] + let newConstitution = + listToMaybe $ + [ script + | (_, preview txSkelOutReferenceScriptAT -> Just script) <- utxo, + Script.toScriptHash script == Script.toScriptHash scriptHash + ] + modify' $ set chainIndexConstitutionL newConstitution + return newConstitution GetCurrentReward (Script.toCredential -> cred) -> do networkId <- getNetworkId stakeCred <- toStakeCredential cred From e086e9b57a5e2684a36ad1017b74e0303a6243ed Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 6 Aug 2026 20:51:09 +0200 Subject: [PATCH 14/18] Utxos == Map TxOutRef TxSkelOut --- cooked-validators.cabal | 1 + package.yaml | 1 + src/Cooked/Families.hs | 5 ++ .../AutoFilling/ReferenceScripts.hs | 7 +- src/Cooked/MockChain/Automation/Balancing.hs | 23 +++--- src/Cooked/MockChain/Common.hs | 3 +- src/Cooked/MockChain/Effect/Read/Chain.hs | 29 ++++---- src/Cooked/MockChain/Effect/Validation.hs | 13 +++- src/Cooked/MockChain/Effect/Write.hs | 20 +++--- src/Cooked/MockChain/UtxoSearch.hs | 71 ++++++++++--------- tests/Spec/Attack/DatumHijacking.hs | 5 +- tests/Spec/Balancing.hs | 39 +++++----- tests/Spec/BasicUsage.hs | 4 +- tests/Spec/InitialDistribution.hs | 6 +- tests/Spec/InlineDatums.hs | 2 +- tests/Spec/MinAda.hs | 3 +- tests/Spec/MultiPurpose.hs | 18 ++--- tests/Spec/ReferenceInputs.hs | 8 +-- tests/Spec/ReferenceScripts.hs | 39 +++++----- 19 files changed, 157 insertions(+), 140 deletions(-) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 15215c98b..0dcf2dcc3 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -160,6 +160,7 @@ library , tasty-quickcheck , text , time + , witherable default-language: Haskell2010 test-suite spec diff --git a/package.yaml b/package.yaml index 75315dd3c..604a003f8 100644 --- a/package.yaml +++ b/package.yaml @@ -42,6 +42,7 @@ library: - tasty-quickcheck - text - time + - witherable ghc-options: -Wall -Wcompat diff --git a/src/Cooked/Families.hs b/src/Cooked/Families.hs index 4cb56f853..c8b562946 100644 --- a/src/Cooked/Families.hs +++ b/src/Cooked/Families.hs @@ -23,6 +23,7 @@ module Cooked.Families HList (..), hHead, hTail, + hSingleton, ) where @@ -89,6 +90,10 @@ hHead (HCons a _) = a hTail :: HList (a ': l) -> HList l hTail (HCons _ l) = l +-- | A singleton wrapped in an 'HList' +hSingleton :: a -> HList '[a] +hSingleton = (`HCons` HEmpty) + instance Eq (HList '[]) where _ == _ = True diff --git a/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs b/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs index 719f8a64b..fb7d48ad1 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs +++ b/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs @@ -17,6 +17,7 @@ import Cooked.Tweak.Query import Cooked.Tweak.Update import Data.List (find) import Data.Map qualified as Map +import Data.Set qualified as Set import Optics.Core import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api @@ -48,11 +49,11 @@ updateRedeemedScript return $ over userRedeemerAT (fillReferenceInput oRef) rs ) $ case oRefsInInputs of - [] -> Nothing + s | null s -> Nothing -- If possible, we use a reference input appearing in regular inputs - l | Just oRefM' <- find (`elem` inputs) l -> Just oRefM' + s | Just oRefM' <- find (`elem` inputs) s -> Just oRefM' -- If none exist, we use the first one we find elsewhere - (oRefM' : _) -> Just oRefM' + s -> Just $ Set.elemAt 0 s updateRedeemedScript _ rs = return rs -- | Goes through the various parts of the skeleton where a redeemer can appear, diff --git a/src/Cooked/MockChain/Automation/Balancing.hs b/src/Cooked/MockChain/Automation/Balancing.hs index f9a179219..45a23f38b 100644 --- a/src/Cooked/MockChain/Automation/Balancing.hs +++ b/src/Cooked/MockChain/Automation/Balancing.hs @@ -26,7 +26,7 @@ import Cooked.MockChain.Runtime.Error import Cooked.MockChain.UtxoSearch import Cooked.Skeleton import Data.ByteString qualified as BS -import Data.List (find, partition) +import Data.List (find) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Ratio qualified as Rat @@ -107,14 +107,13 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- Some scripts involved, and a specific collateral user provided. -- We fetch vanilla UTxOs from this user and return them. (False, CollateralUtxosFromUser (Script.toPubKeyHash -> cUser)) -> - Just . (,UserPubKey cUser) . Set.fromList - <$> getTxOutRefs (utxosAtSearch cUser ensureOnlyValueOutputs) + Just . (,UserPubKey cUser) <$> getTxOutRefs (utxosAtSearch cUser ensureOnlyValueOutputs) -- Some scripts involved, and no specific collateral options provided. (False, CollateralUtxosFromBalancingUser) -> case balancingUser of -- If no balancing wallet exists, we throw an error Nothing -> throw $ MCEBalancingError MissingBalancingUser -- If a balancing wallet exists, we use it as collateral user - Just bUser -> Just . (,bUser) . Set.fromList <$> getTxOutRefs (utxosAtSearch bUser ensureOnlyValueOutputs) + Just bUser -> Just . (,bUser) <$> getTxOutRefs (utxosAtSearch bUser ensureOnlyValueOutputs) -- At this point, the presence (or absence) of balancing user dictates -- whether the transaction should be automatically balanced or not. @@ -133,16 +132,16 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- utxos based on the associated policy balancingUtxos <- case txSkelOptBalancingUtxos txSkelOpts of - BalancingUtxosFromBalancingUser -> getTxOutRefsAndOutputs $ utxosAtSearch bUser ensureOnlyValueOutputs + BalancingUtxosFromBalancingUser -> getUtxos $ utxosAtSearch bUser ensureOnlyValueOutputs BalancingUtxosFromSet utxos -> -- We resolve the given set of utxos - getTxOutRefsAndOutputs (txSkelOutByRefSearch' (Set.toList utxos)) + getUtxos (txSkelOutByRefSearch' utxos) -- We filter out those belonging to scripts, while throwing a -- warning if any was actually discarded. - >>= filterAndWarn (is (txSkelOutOwnerL % userPubKeyHashAT) . snd) "They belong to scripts." + >>= filterAndWarn (const $ is (txSkelOutOwnerL % userPubKeyHashAT)) "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." + >>= filterAndWarn (flip $ const (`notElem` txSkelKnownTxOutRefs skelUnbal)) "They are already used in the skeleton." case txSkelOptFeePolicy txSkelOpts of -- If fees are left for us to compute, we run a dichotomic search. This @@ -158,7 +157,7 @@ balanceTxSkel skelUnbal@TxSkel {..} = do return $ ExtendedTxSkel balancedSkel fee mCols cBody where filterAndWarn f s l - | (ok, toInteger . length -> koLength) <- partition f l = + | (ok, toInteger . length -> koLength) <- Map.partitionWithKey f l = unless (koLength == 0) (logEvent $ MCLogDiscardedUtxos koLength s) >> return ok -- | Computes optimal fee for a given skeleton and balances it around those fees. @@ -244,7 +243,7 @@ collateralsFromFee fee (Just (collateralIns, returnCollateralUser)) = do -- add one because of ledger requirement which seem to round up this value. let totalCollateral = Script.lovelace . (+ 1) . (`div` 100) . (* percentage) $ fee -- Collateral tx outputs sorted by decreasing ada amount - collateralTxOuts <- getTxOutRefsAndOutputs $ txSkelOutByRefSearch' $ Set.toList collateralIns + collateralTxOuts <- getUtxos $ txSkelOutByRefSearch' collateralIns -- Candidate subsets of utxos to be used as collaterals reachedValue <- reachValue collateralTxOuts totalCollateral nbMax $ Right returnCollateralUser -- A value might, or might not have been reached @@ -273,7 +272,7 @@ reachValue :: -- the surplus output, which is either built from scratch or from the provided -- surplus output, if any. Sem effs (Maybe ([Api.TxOutRef], Maybe TxSkelOut)) -reachValue utxos target fuel outputOrUser = do +reachValue (Map.toList -> utxos) target fuel outputOrUser = do -- We retrieve the current protocol version, which is going to be used to -- compute the size of the inputs and outputs added by this function Cardano.ProtVer majorVersion _ <- Microlens.view Conway.ppProtocolVersionL <$> getParams @@ -468,7 +467,7 @@ computeBalancedTxSkel balancingUser balancingUtxos txSkel@TxSkel {..} (Script.lo (additionalInsTxOutRefs, newTxSkelOuts) <- case solution of -- There is no solution with the provided parameters Nothing -> do - let totalValue = mconcat $ view txSkelOutValueL . snd <$> balancingUtxos + let totalValue = foldOf (traversed % txSkelOutValueL) balancingUtxos difference = snd $ Api.split $ missingLeft <> PlutusTx.negate totalValue throw $ MCEBalancingError $ diff --git a/src/Cooked/MockChain/Common.hs b/src/Cooked/MockChain/Common.hs index e8429773a..ccd0f7d83 100644 --- a/src/Cooked/MockChain/Common.hs +++ b/src/Cooked/MockChain/Common.hs @@ -10,6 +10,7 @@ module Cooked.MockChain.Common where import Cooked.Skeleton.Output +import Data.Map (Map) import Data.Set (Set) import PlutusLedgerApi.V3 qualified as Api @@ -29,4 +30,4 @@ type Collaterals = (CollateralIns, Maybe TxSkelOut) type Utxo = (Api.TxOutRef, TxSkelOut) -- | An alias for lists of `Utxo` -type Utxos = [Utxo] +type Utxos = Map Api.TxOutRef TxSkelOut diff --git a/src/Cooked/MockChain/Effect/Read/Chain.hs b/src/Cooked/MockChain/Effect/Read/Chain.hs index ee2f61ac5..6197eddb2 100644 --- a/src/Cooked/MockChain/Effect/Read/Chain.hs +++ b/src/Cooked/MockChain/Effect/Read/Chain.hs @@ -53,10 +53,10 @@ import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton -import Data.Bifunctor import Data.Coerce (coerce) import Data.Map (Map) import Data.Map qualified as Map +import Data.Map.Optics (toMapOf) import Data.Maybe import Data.Maybe.Strict import Data.Set qualified as Set @@ -300,13 +300,12 @@ runMockChainReadChainEmul = interpret $ \case where fetchUtxos decide = gets $ - toListOf $ + toMapOf $ chainIndexOutputsL - % to Map.toList - % traversed - % filtered (snd . snd) - % filtered (decide . fst . snd) - % to (fmap fst) + % itraversed + % filtered snd + % filtered (decide . fst) + % to fst -- | Interpret the `MockChainReadChain` effect by talking to a deployed node -- through a `Cardano.LocalNodeConnectInfo` (socket path and network id) @@ -353,11 +352,7 @@ runMockChainReadChainNode = interpret $ \case TxSkelOutByRef oRef -> do txIn <- fromEither $ P.Ledger.toCardanoTxIn oRef utxo <- queryUtxosAndHandleErrors $ Cardano.QueryUTxOByTxIn $ Set.singleton txIn - case utxo of - [(_, txSkelOut)] -> return txSkelOut - -- This case is reduced to [] as there can never be more than one UTxO - -- with a given 'Api.TxOutRef'. - _ -> throw $ MCEUnknownOutRef oRef + maybe (throw $ MCEUnknownOutRef oRef) return $ Map.lookup oRef utxo GetConstitutionScript -> do -- We retrieve the official optional script hash of the current constitution Cardano.Constitution _ mScriptHash <- @@ -396,7 +391,7 @@ runMockChainReadChainNode = interpret $ \case let newConstitution = listToMaybe $ [ script - | (_, preview txSkelOutReferenceScriptAT -> Just script) <- utxo, + | (_, preview txSkelOutReferenceScriptAT -> Just script) <- Map.toList utxo, Script.toScriptHash script == Script.toScriptHash scriptHash ] modify' $ set chainIndexConstitutionL newConstitution @@ -422,10 +417,14 @@ runMockChainReadChainNode = interpret $ \case -- Handles a second layer of error from the response of a query queryAndHandleErrors q = queryAndHandleError q >>= fromEither -- Queries the Utxos present on-chain, handling the errors, and returns the - -- query result in terms of @Utxos@ + -- query result in terms of @Utxos@, updated with the known chain index. queryUtxosAndHandleErrors utxoFilter = do utxo <- queryAndHandleErrors $ Cardano.queryUtxo Cardano.ShelleyBasedEraConway utxoFilter - return $ bimap P.Ledger.fromCardanoTxIn convertUtxo <$> Map.toList (Cardano.unUTxO utxo) + knownUtxos <- gets chainIndexOutputs + return $ + Map.mapWithKey + (\oRef txSkelOut -> maybe txSkelOut fst $ Map.lookup oRef knownUtxos) + (Map.mapKeysMonotonic P.Ledger.fromCardanoTxIn $ convertUtxo <$> Cardano.unUTxO utxo) -- Retrieves the Plutus slot number from a chain tip chainTipSlot Cardano.ChainTipAtGenesis = P.Ledger.Slot 0 chainTipSlot (Cardano.ChainTip slotNo _ _) = fromSlotNo slotNo diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs index 8fefa3871..8882e95ad 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -14,6 +14,7 @@ module Cooked.MockChain.Effect.Validation -- * Sending `Cooked.Skeleton.TxSkel`s for validation validateTxSkel, validateTxSkel', + validateTxSkelL, validateTxSkel_, ) where @@ -30,11 +31,13 @@ import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton import Data.Map.Strict qualified as Map +import Data.Set qualified as Set import Ledger.Index qualified as P.Ledger import Ledger.Orphans () import Ledger.Tx qualified as P.Ledger import Ledger.Tx.CardanoAPI qualified as P.Ledger import Optics.Core +import PlutusLedgerApi.V3 qualified as Api import Polysemy import Polysemy.Error import Polysemy.Fail @@ -53,9 +56,13 @@ makeSem_ ''MockChainValidate validateTxSkel :: (Member MockChainValidate effs) => TxSkel -> Sem effs (P.Ledger.CardanoTx, Utxos) -- | Same as `validateTxSkel`, but only returns the generated UTxOs -validateTxSkel' :: (Members '[MockChainReadChain, MockChainValidate] effs) => TxSkel -> Sem effs Utxos +validateTxSkel' :: (Member MockChainValidate effs) => TxSkel -> Sem effs Utxos validateTxSkel' = fmap snd . validateTxSkel +-- | Same as `validateTxSkel`, but only returns the list of 'Api.TxOutRef' +validateTxSkelL :: (Member MockChainValidate effs) => TxSkel -> Sem effs [Api.TxOutRef] +validateTxSkelL = fmap (Set.toList . Map.keysSet . snd) . validateTxSkel + -- | Same as `validateTxSkel`, but discards the returned transaction validateTxSkel_ :: (Member MockChainValidate effs) => TxSkel -> Sem effs () validateTxSkel_ = void . validateTxSkel @@ -117,7 +124,7 @@ runMockChainValidateEmul = interpret $ \case -- And remove the old ones forM_ (Map.toList $ txSkelInputs finalTxSkel) $ modify' . removeOutput . fst -- We return the newly created outputs - return newOutputs + return $ Map.fromList newOutputs -- This is a theoretical unreachable case. Since we fail in Phase 2, it -- means the transaction involved script, and thus we must have generated -- collaterals. @@ -178,7 +185,7 @@ runMockChainValidateNode = interpret $ \case -- created outputs and drop the consumed ones from our local state. Cardano.SubmitSuccess -> do let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx - newOutputs = zip utxos (txSkelOutputs finalTxSkel) + newOutputs = Map.fromList $ zip utxos (txSkelOutputs finalTxSkel) logEvent $ MCLogNewTx (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index c9591ff1f..6c27f383e 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -37,6 +37,7 @@ import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton +import Data.Map.Optics (toMapOf) import Data.Map.Strict qualified as Map import Ledger.Index qualified as P.Ledger import Ledger.Orphans () @@ -134,19 +135,16 @@ runMockChainWrite = interpret $ \case (P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx) outputsMinAda -- We update the index, which effectively receives the new utxos - modify' - ( over emulatorStateLedgerStateL $ - Lens.over - Emulator.elsUtxoL - ( P.Ledger.fromPlutusIndex - . P.Ledger.insert cardanoTx - . P.Ledger.toPlutusIndex - ) - ) + modify' $ + over emulatorStateLedgerStateL $ + Lens.over Emulator.elsUtxoL $ + P.Ledger.fromPlutusIndex + . P.Ledger.insert cardanoTx + . P.Ledger.toPlutusIndex -- We update our internal map by adding the new outputs - modify' (over chainIndexOutputsL (<> outputsMap)) + modify' $ over chainIndexOutputsL (<> outputsMap) -- Finally, we return the created utxos - return $ Map.toList (fst <$> outputsMap) + return $ toMapOf (itraversed % to fst) outputsMap -- | Waits a certain number of slots and returns the new slot waitNSlots :: (Member MockChainWrite effs) => Integer -> Sem effs P.Ledger.Slot diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index 2c0e9d3c3..248bcf638 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/MockChain/UtxoSearch.hs @@ -8,12 +8,13 @@ module Cooked.MockChain.UtxoSearch beginSearchPure, -- * Processing search result + RefinedOutputsList, UtxoSearchResult, - getOutputs, + utxosSearchResultUtxosI, + getUtxos, getOutputsAndExtracts, getExtracts, getTxOutRefs, - getTxOutRefsAndOutputs, -- * Basic UTxO searches utxosAtSearch, @@ -42,26 +43,34 @@ module Cooked.MockChain.UtxoSearch ) where -import Control.Monad (filterM, forM) +import Control.Monad (foldM) import Cooked.Families hiding (Member) import Cooked.MockChain.Common import Cooked.MockChain.Effect.Read.Chain import Cooked.Skeleton.Datum import Cooked.Skeleton.Output import Cooked.Skeleton.Value -import Data.Functor -import Data.Maybe +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Set import Optics.Core import Optics.Core.Extras import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api import Polysemy +import Witherable + +type RefinedOutputsList elems = HList (TxSkelOut ': elems) -- | Raw result of a `UtxoSearch`. We store the `Api.TxOutRef` of the output, -- alongside an heterogeneous list starting with the output in question, -- followed by any element that was extracted during the search. -type UtxoSearchResult elems = [(Api.TxOutRef, HList (TxSkelOut ': elems))] +type UtxoSearchResult elems = Map Api.TxOutRef (RefinedOutputsList elems) + +-- | An isomorphisms between `Utxos` and search results with no extra element. +utxosSearchResultUtxosI :: Iso' (UtxoSearchResult '[]) Utxos +utxosSearchResultUtxosI = iso (fmap hHead) (fmap hSingleton) -- | A `UtxoSearch` is a computation that returns a list of UTxOs alongside -- their `TxSkelOut` counterpart and a list of other elements retrieved from the @@ -73,7 +82,7 @@ type UtxoSearch effs elems = Sem effs (UtxoSearchResult elems) beginSearch :: Sem effs Utxos -> UtxoSearch effs '[] -beginSearch = fmap (fmap (fmap (`HCons` HEmpty))) +beginSearch = fmap $ review utxosSearchResultUtxosI -- | Same as `beginSearch` with a pure input beginSearchPure :: @@ -82,36 +91,29 @@ beginSearchPure :: beginSearchPure = beginSearch . return -- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` -getOutputs :: +getUtxos :: Sem effs (UtxoSearchResult elems) -> - Sem effs [TxSkelOut] -getOutputs = fmap (fmap (hHead . snd)) + Sem effs Utxos +getUtxos = fmap (fmap hHead) -- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` alongside the -- extracted elements getOutputsAndExtracts :: Sem effs (UtxoSearchResult elems) -> - Sem effs [(TxSkelOut, HList elems)] -getOutputsAndExtracts = - fmap (fmap (\(_, HCons output l) -> (output, l))) + Sem effs [RefinedOutputsList elems] +getOutputsAndExtracts = fmap Map.elems -- | Retrieves the extracted elements from a `UtxoSearchResult` getExtracts :: Sem effs (UtxoSearchResult elems) -> Sem effs [HList elems] -getExtracts = fmap (fmap (hTail . snd)) +getExtracts = fmap (Map.elems . fmap hTail) -- | Retrieves the `Api.TxOutRef`s from a `UtxoSearchResult` getTxOutRefs :: Sem effs (UtxoSearchResult elems) -> - Sem effs [Api.TxOutRef] -getTxOutRefs = fmap (fmap fst) - --- | Retrieves both the `Api.TxOutRef`s and `TxSkelOut`s from a `UtxoSearchResult` -getTxOutRefsAndOutputs :: - Sem effs (UtxoSearchResult elems) -> - Sem effs Utxos -getTxOutRefsAndOutputs = fmap (fmap (\(oRef, HCons output _) -> (oRef, output))) + Sem effs (Set Api.TxOutRef) +getTxOutRefs = fmap Map.keysSet -- | Searches for utxos at a given address with a given filter utxosAtSearch :: @@ -131,32 +133,31 @@ allUtxosSearch filters = filters $ beginSearch allUtxos -- | Searches for utxos belonging to a given list with a given filter txSkelOutByRefSearch :: (Member MockChainReadChain effs) => - [Api.TxOutRef] -> + Set Api.TxOutRef -> (UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els txSkelOutByRefSearch utxos filters = - filters $ beginSearch (zip utxos <$> mapM txSkelOutByRef utxos) + filters $ + foldM + (\acc oRef -> (\x -> Map.insert oRef (hSingleton x) acc) <$> txSkelOutByRef oRef) + Map.empty + utxos -- | Searches for utxos belonging to a given list with no filter txSkelOutByRefSearch' :: (Member MockChainReadChain effs) => - [Api.TxOutRef] -> + Set Api.TxOutRef -> UtxoSearch effs '[] txSkelOutByRefSearch' = (`txSkelOutByRefSearch` id) --- | Extracts a new element from the currently selected outputs, filtering in --- the process out utxos for which this element is not available +-- | Extracts a new element from the currently selected outputs, filtering out +-- in the process utxos for which this element is not available extract :: (TxSkelOut -> Sem effs (Maybe b)) -> UtxoSearch effs els -> UtxoSearch effs (b ': els) -extract extractFun comp = do - resl <- comp - resl' <- forM resl $ - \(oRef, HCons txSkelOut other) -> do - res <- extractFun txSkelOut - return $ res <&> (\x -> (oRef, HCons txSkelOut (HCons x other))) - return $ catMaybes resl' +extract extractFun = + (>>= witherM (\(HCons txSkelOut es) -> fmap (HCons txSkelOut . (`HCons` es)) <$> extractFun txSkelOut)) -- | Same as `extract`, but with a pure extraction function extractPure :: @@ -201,7 +202,7 @@ ensure :: UtxoSearch effs els -> UtxoSearch effs els ensure filterF comp = - comp >>= filterM (filterF . hHead . snd) + comp >>= filterA (filterF . hHead) -- | Same as `ensure`, but with a pure predicate ensurePure :: diff --git a/tests/Spec/Attack/DatumHijacking.hs b/tests/Spec/Attack/DatumHijacking.hs index 25630b36e..9a6202a28 100644 --- a/tests/Spec/Attack/DatumHijacking.hs +++ b/tests/Spec/Attack/DatumHijacking.hs @@ -4,6 +4,7 @@ module Spec.Attack.DatumHijacking (tests) where import Cooked 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 @@ -30,8 +31,8 @@ lockTxSkel o v = txLock :: Script.MultiPurposeScript DHContract -> StagedMockChain Api.TxOutRef txLock v = do - oref : _ <- getTxOutRefs $ utxosAtSearch (wallet 1) $ ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` lockValue)) - fst . head <$> validateTxSkel' (lockTxSkel oref v) + oRefs <- getTxOutRefs $ utxosAtSearch (wallet 1) $ ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` lockValue)) + head <$> validateTxSkelL (lockTxSkel (Set.elemAt 0 oRefs) v) relockTxSkel :: Script.MultiPurposeScript DHContract -> Api.TxOutRef -> TxSkel relockTxSkel v o = diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index 6e9480292..95e121674 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -5,6 +5,7 @@ import Data.Default import Data.List qualified as List import Data.Map (Map) import Data.Map qualified as Map +import Data.Set (Set) import Data.Set qualified as Set import Data.Text (isInfixOf) import Ledger.Index qualified as P.Ledger @@ -37,13 +38,11 @@ initialDistributionBalancing = alice `receives` FixedValue (Script.ada 105 <> banana 2) <&&> VisibleHashedDatum () ] -type TestBalancingOutcome = (TxSkel, TxSkel, Fee, Maybe Collaterals, [Api.TxOutRef]) +type TestBalancingOutcome = (TxSkel, TxSkel, Fee, Maybe Collaterals, Set Api.TxOutRef) spendsScriptUtxo :: Bool -> FullMockChain (Map Api.TxOutRef TxSkelRedeemer) spendsScriptUtxo False = return Map.empty -spendsScriptUtxo True = do - (scriptOutRef, _) : _ <- utxosAt $ Script.trueSpendingMPScript @() - return $ Map.singleton scriptOutRef emptyTxSkelRedeemerNoAutoFill +spendsScriptUtxo True = fmap (const emptyTxSkelRedeemerNoAutoFill) <$> utxosAt (Script.trueSpendingMPScript @()) testingBalancingTemplate :: -- Value to pay to bob @@ -51,11 +50,11 @@ testingBalancingTemplate :: -- Value to pay back to alice Api.Value -> -- utxos to be spent - FullMockChain [Api.TxOutRef] -> + FullMockChain (Set Api.TxOutRef) -> -- utxos to be used for balancing - FullMockChain [Api.TxOutRef] -> + FullMockChain (Set Api.TxOutRef) -> -- utxos to be used for collaterals - FullMockChain [Api.TxOutRef] -> + FullMockChain (Set Api.TxOutRef) -> -- Whether to consum the script utxo Bool -> -- Option modifications @@ -77,18 +76,18 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla [ bob `receives` valueConstr toBobValue, alice `receives` valueConstr toAliceValue ], - txSkelInputs = additionalSpend <> Map.fromList ((,emptyTxSkelRedeemer) <$> toSpendUtxos), + txSkelInputs = additionalSpend <> Map.fromSet (const emptyTxSkelRedeemer) toSpendUtxos, txSkelOpts = optionsMod def { txSkelOptBalancingUtxos = if List.null toBalanceUtxos then BalancingUtxosFromBalancingUser - else BalancingUtxosFromSet $ Set.fromList toBalanceUtxos, + else BalancingUtxosFromSet toBalanceUtxos, txSkelOptCollateralUtxos = if List.null toCollateralUtxos then CollateralUtxosFromBalancingUser - else CollateralUtxosFromSet (Set.fromList toCollateralUtxos) alice + else CollateralUtxosFromSet toCollateralUtxos alice }, txSkelSignatories = txSkelSignatoriesFromList [alice] } @@ -97,7 +96,7 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla nonOnlyValueUtxos <- aliceNonOnlyValueUtxos return (skel, skel', fee, mCols, nonOnlyValueUtxos) -aliceNonOnlyValueUtxos :: FullMockChain [Api.TxOutRef] +aliceNonOnlyValueUtxos :: FullMockChain (Set Api.TxOutRef) aliceNonOnlyValueUtxos = getTxOutRefs $ utxosAtSearch alice $ @@ -105,20 +104,20 @@ aliceNonOnlyValueUtxos = is txSkelOutReferenceScriptAT skel || is (txSkelOutDatumL % txSkelOutDatumKindAT) skel -aliceNAdaUtxos :: Integer -> FullMockChain [Api.TxOutRef] +aliceNAdaUtxos :: Integer -> FullMockChain (Set Api.TxOutRef) aliceNAdaUtxos n = getTxOutRefs $ utxosAtSearch alice $ ensureAFoldIs (txSkelOutValueL % valueLovelaceL % filtered (== Api.Lovelace (n * 1_000_000))) -aliceRefScriptUtxos :: FullMockChain [Api.TxOutRef] +aliceRefScriptUtxos :: FullMockChain (Set Api.TxOutRef) aliceRefScriptUtxos = getTxOutRefs $ utxosAtSearch alice $ ensureAFoldIs txSkelOutReferenceScriptAT -emptySearch :: FullMockChain [Api.TxOutRef] -emptySearch = return [] +emptySearch :: FullMockChain (Set Api.TxOutRef) +emptySearch = return Set.empty simplePaymentToBob :: Integer -> Integer -> Integer -> Integer -> Bool -> (TxSkelOpts -> TxSkelOpts) -> Bool -> FullMockChain TestBalancingOutcome simplePaymentToBob lv apples oranges bananas = @@ -141,11 +140,11 @@ bothPaymentsToBobAndAlice val = noBalanceMaxFee :: FullMockChain () noBalanceMaxFee = do maxFee <- snd <$> getMinAndMaxFee 0 - (txOutRef : _) <- aliceNAdaUtxos 30 + aliceORefs30Ada <- aliceNAdaUtxos 30 validateTxSkel_ $ txSkelTemplate { txSkelOutputs = [bob `receives` Value (Script.lovelace (30_000_000 - maxFee))], - txSkelInputs = Map.singleton txOutRef emptyTxSkelRedeemer, + txSkelInputs = Map.fromSet (const emptyTxSkelRedeemer) aliceORefs30Ada, txSkelOpts = def { txSkelOptBalancingPolicy = DoNotBalance, @@ -183,7 +182,7 @@ reachingMagic = do txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelOpts = def - { txSkelOptBalancingUtxos = BalancingUtxosFromSet (Set.fromList bananaOutRefs) + { txSkelOptBalancingUtxos = BalancingUtxosFromSet bananaOutRefs } } @@ -457,7 +456,7 @@ tests = ( testingBalancingTemplate (Script.ada 142) mempty - ((fst <$>) <$> utxosAt alice) + (Map.keysSet <$> utxosAt alice) emptySearch (aliceNAdaUtxos 1) True @@ -641,7 +640,7 @@ tests = (apple 2 <> orange 5 <> banana 4) mempty emptySearch - ((fst <$>) <$> utxosAt alice) + (Map.keysSet <$> utxosAt alice) emptySearch False (setFixedFee 1_000_000) diff --git a/tests/Spec/BasicUsage.hs b/tests/Spec/BasicUsage.hs index 812ccf001..2c8a08e5d 100644 --- a/tests/Spec/BasicUsage.hs +++ b/tests/Spec/BasicUsage.hs @@ -38,8 +38,8 @@ mintingQuickValue = payToAlwaysTrueValidator :: StagedMockChain Api.TxOutRef payToAlwaysTrueValidator = - fst . head - <$> ( validateTxSkel' $ + head + <$> ( validateTxSkelL $ txSkelTemplate { txSkelOutputs = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 10)], txSkelSignatories = txSkelSignatoriesFromList [alice] diff --git a/tests/Spec/InitialDistribution.hs b/tests/Spec/InitialDistribution.hs index f67421d97..6fc815084 100644 --- a/tests/Spec/InitialDistribution.hs +++ b/tests/Spec/InitialDistribution.hs @@ -29,9 +29,9 @@ getValueFromInitialDatum = do spendReferenceAlwaysTrueValidator :: DirectMockChain () spendReferenceAlwaysTrueValidator = do - [(referenceScriptTxOutRef, _)] <- utxosAt alice - ((scriptTxOutRef, _) : _) <- - validateTxSkel' $ + (fst . Map.elemAt 0 -> referenceScriptTxOutRef) <- utxosAt alice + (scriptTxOutRef : _) <- + validateTxSkelL $ txSkelTemplate { txSkelOutputs = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 2)], txSkelSignatories = txSkelSignatoriesFromList [bob] diff --git a/tests/Spec/InlineDatums.hs b/tests/Spec/InlineDatums.hs index 72af6fcd7..24bcdcbe1 100644 --- a/tests/Spec/InlineDatums.hs +++ b/tests/Spec/InlineDatums.hs @@ -23,7 +23,7 @@ listUtxosTestTrace :: Script.Versioned Script.Validator -> DirectMockChain (Api.TxOutRef, TxSkelOut) listUtxosTestTrace useInlineDatum validator = - head + Map.elemAt 0 <$> validateTxSkel' txSkelTemplate { txSkelOutputs = [validator `receives` (if useInlineDatum then InlineDatum else VisibleHashedDatum) FirstPaymentDatum], diff --git a/tests/Spec/MinAda.hs b/tests/Spec/MinAda.hs index 5b0b31e85..6989b65eb 100644 --- a/tests/Spec/MinAda.hs +++ b/tests/Spec/MinAda.hs @@ -1,6 +1,7 @@ module Spec.MinAda where import Cooked +import Data.Map qualified as Map import Optics.Core import Plutus.Script.Utils.Value qualified as Script import PlutusTx qualified @@ -24,7 +25,7 @@ instance PrettyCooked HeavyDatum where paymentWithMinAda :: DirectMockChain Integer paymentWithMinAda = do forceOutputs_ initialDistributionTemplate - view (txSkelOutValueL % valueLovelaceL % lovelaceIntegerI) . snd . (!! 0) + view (txSkelOutValueL % valueLovelaceL % lovelaceIntegerI) . snd . Map.elemAt 0 <$> validateTxSkel' txSkelTemplate { txSkelOutputs = [wallet 2 `receives` VisibleHashedDatum heavyDatum], diff --git a/tests/Spec/MultiPurpose.hs b/tests/Spec/MultiPurpose.hs index 80b6116d5..42cf92751 100644 --- a/tests/Spec/MultiPurpose.hs +++ b/tests/Spec/MultiPurpose.hs @@ -25,8 +25,8 @@ bob = wallet 2 runScript :: StagedMockChain () runScript = do forceOutputs_ initialDistributionTemplate - [(oRef@(Api.TxOutRef txId _), _), (oRef', _), (oRef'', _)] <- - validateTxSkel' $ + [oRef@(Api.TxOutRef txId _), oRef', oRef''] <- + validateTxSkelL $ txSkelTemplate { txSkelOutputs = [ alice `receives` Value (Script.ada 3), @@ -40,12 +40,12 @@ runScript = do (mintSkel2, mintValue2, tn2) = mkMintSkel alice oRef' script (mintSkel3, mintValue3, tn3) = mkMintSkel bob oRef'' script - ((oRefScript, _) : _) <- validateTxSkel' mintSkel1 - ((oRefScript1, _) : _) <- validateTxSkel' mintSkel2 - ((oRefScript2, _) : _) <- validateTxSkel' mintSkel3 + (oRefScript : _) <- validateTxSkelL mintSkel1 + (oRefScript1 : _) <- validateTxSkelL mintSkel2 + (oRefScript2 : _) <- validateTxSkelL mintSkel3 - ((oRefScript1', _) : (oRefScript2', _) : _) <- - validateTxSkel' $ + (oRefScript1' : oRefScript2' : _) <- + validateTxSkelL $ txSkelTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelInputs = @@ -61,8 +61,8 @@ runScript = do txSkelMints = review txSkelMintsListI [burn script BurnToken tn1 1] } - ((oRefScript2'', _) : _) <- - validateTxSkel' $ + (oRefScript2'' : _) <- + validateTxSkelL $ txSkelTemplate { txSkelSignatories = txSkelSignatoriesFromList [bob], txSkelInputs = diff --git a/tests/Spec/ReferenceInputs.hs b/tests/Spec/ReferenceInputs.hs index 37aec79b1..234951169 100644 --- a/tests/Spec/ReferenceInputs.hs +++ b/tests/Spec/ReferenceInputs.hs @@ -15,8 +15,8 @@ instance PrettyCooked FooDatum where trace1 :: DirectMockChain () trace1 = do - (txOutRefFoo, _) : (txOutRefBar, _) : _ <- - validateTxSkel' + txOutRefFoo : txOutRefBar : _ <- + validateTxSkelL txSkelTemplate { txSkelOutputs = [ fooTypedValidator `receives` Value (Script.ada 4) <&&> InlineDatum (FooDatum $ Script.toPubKeyHash $ wallet 3), @@ -34,8 +34,8 @@ trace1 = do trace2 :: DirectMockChain () trace2 = do - (refORef, _) : (scriptORef, _) : _ <- - validateTxSkel' + refORef : scriptORef : _ <- + validateTxSkelL ( txSkelTemplate { txSkelOutputs = [ wallet 1 `receives` Value (Script.ada 2) <&&> VisibleHashedDatum (10 :: Integer), diff --git a/tests/Spec/ReferenceScripts.hs b/tests/Spec/ReferenceScripts.hs index b92a46a51..a5e6e6690 100644 --- a/tests/Spec/ReferenceScripts.hs +++ b/tests/Spec/ReferenceScripts.hs @@ -18,8 +18,8 @@ putRefScriptOnWalletOutput :: Script.Versioned Script.Validator -> DirectMockChain V3.TxOutRef putRefScriptOnWalletOutput recipient referenceScript = - fst . head - <$> validateTxSkel' + head + <$> validateTxSkelL txSkelTemplate { txSkelOutputs = [recipient `receives` ReferenceScript referenceScript], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -30,8 +30,8 @@ putRefScriptOnScriptOutput :: Script.Versioned Script.Validator -> DirectMockChain V3.TxOutRef putRefScriptOnScriptOutput recipient referenceScript = - fst . head - <$> validateTxSkel' + head + <$> validateTxSkelL txSkelTemplate { txSkelOutputs = [recipient `receives` ReferenceScript referenceScript], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -42,8 +42,8 @@ checkReferenceScriptOnOref :: V3.TxOutRef -> DirectMockChain () checkReferenceScriptOnOref expectedScriptHash refScriptOref = do - (oref, _) : _ <- - validateTxSkel' + oref : _ <- + validateTxSkelL txSkelTemplate { txSkelOutputs = [requireRefScriptValidator expectedScriptHash `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -62,8 +62,8 @@ checkReferenceScriptOnOref expectedScriptHash refScriptOref = do useReferenceScript :: Wallet -> Bool -> Script.Versioned Script.Validator -> DirectMockChain P.Ledger.CardanoTx useReferenceScript spendingSubmitter consumeScriptOref theScript = do scriptOref <- putRefScriptOnWalletOutput (wallet 3) theScript - (oref, _) : _ <- - validateTxSkel' + oref : _ <- + validateTxSkelL txSkelTemplate { txSkelOutputs = [theScript `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -81,8 +81,8 @@ useReferenceScript spendingSubmitter consumeScriptOref theScript = do useReferenceScriptInInputs :: Wallet -> Script.Versioned Script.Validator -> DirectMockChain () useReferenceScriptInInputs spendingSubmitter theScript = do scriptOref <- putRefScriptOnWalletOutput (wallet 1) theScript - (oref, _) : _ <- - validateTxSkel' + oref : _ <- + validateTxSkelL txSkelTemplate { txSkelOutputs = [theScript `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -95,7 +95,7 @@ useReferenceScriptInInputs spendingSubmitter theScript = do referenceMint :: Script.Versioned Script.MintingPolicy -> Script.Versioned Script.MintingPolicy -> Int -> Bool -> DirectMockChain () referenceMint mp1 mp2 n autoRefScript = do - ((!! n) -> (mpOutRef, _)) <- + (Map.elemAt n -> (mpOutRef, _)) <- validateTxSkel' $ txSkelTemplate { txSkelOutputs = @@ -148,9 +148,12 @@ tests = [ testCookedFromInitDistTemplate @DirectEffs "fail from transaction generation for missing reference scripts" $ mustFailTest ( do - consumedOref : _ <- getTxOutRefs $ utxosAtSearch (wallet 1) $ ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` Script.lovelace 42_000_000)) - (oref, _) : _ <- - validateTxSkel' + (Set.elemAt 0 -> consumedOref) <- + getTxOutRefs $ + utxosAtSearch (wallet 1) $ + ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` Script.lovelace 42_000_000)) + oref : _ <- + validateTxSkelL txSkelTemplate { txSkelOutputs = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], txSkelInputs = Map.singleton consumedOref emptyTxSkelRedeemer, @@ -169,8 +172,8 @@ tests = mustFailTest ( do scriptOref <- putRefScriptOnWalletOutput (wallet 3) Script.alwaysFailValidatorVersioned - (oref, _) : _ <- - validateTxSkel' + oref : _ <- + validateTxSkelL txSkelTemplate { txSkelOutputs = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -187,8 +190,8 @@ tests = testCookedFromInitDistTemplate "phase 1 - fail if using a reference script with 'someRedeemer'" $ mustFailInPhase1Test $ do scriptOref <- putRefScriptOnWalletOutput (wallet 3) Script.alwaysSucceedValidatorVersioned - (oref, _) : _ <- - validateTxSkel' + oref : _ <- + validateTxSkelL txSkelTemplate { txSkelOutputs = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] From c063def86f185ff6868025e7bf46d5db203aa90d Mon Sep 17 00:00:00 2001 From: mmontin Date: Fri, 7 Aug 2026 00:33:14 +0200 Subject: [PATCH 15/18] move pipeline into umbrella automation module --- cooked-validators.cabal | 2 +- src/Cooked/MockChain.hs | 3 +- .../{Automation/Pipeline.hs => Automation.hs} | 32 ++++++++++++++----- src/Cooked/MockChain/Effect/Validation.hs | 2 +- 4 files changed, 27 insertions(+), 12 deletions(-) rename src/Cooked/MockChain/{Automation/Pipeline.hs => Automation.hs} (66%) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 0dcf2dcc3..21d10974e 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -24,6 +24,7 @@ library Cooked.Families Cooked.Ltl Cooked.MockChain + Cooked.MockChain.Automation Cooked.MockChain.Automation.AutoFilling.Constitution Cooked.MockChain.Automation.AutoFilling.MinAda Cooked.MockChain.Automation.AutoFilling.ReferenceScripts @@ -41,7 +42,6 @@ library Cooked.MockChain.Automation.GenerateTx.ReferenceInputs Cooked.MockChain.Automation.GenerateTx.Withdrawals Cooked.MockChain.Automation.GenerateTx.Witness - Cooked.MockChain.Automation.Pipeline Cooked.MockChain.Common Cooked.MockChain.Effect.Log Cooked.MockChain.Effect.Misc diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index b83765ae6..e5720a6c9 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -2,8 +2,7 @@ -- elements related to logs and inner state. module Cooked.MockChain (module X) where -import Cooked.MockChain.Automation.Balancing as X -import Cooked.MockChain.Automation.Pipeline as X +import Cooked.MockChain.Automation as X import Cooked.MockChain.Common as X import Cooked.MockChain.Effect.Misc as X import Cooked.MockChain.Effect.Read.Chain as X diff --git a/src/Cooked/MockChain/Automation/Pipeline.hs b/src/Cooked/MockChain/Automation.hs similarity index 66% rename from src/Cooked/MockChain/Automation/Pipeline.hs rename to src/Cooked/MockChain/Automation.hs index 64b327357..8c60e5cd2 100644 --- a/src/Cooked/MockChain/Automation/Pipeline.hs +++ b/src/Cooked/MockChain/Automation.hs @@ -1,14 +1,30 @@ -module Cooked.MockChain.Automation.Pipeline +-- | This module runs the full automation pipeline that completes a +-- `Cooked.Skeleton.TxSkel` into an actual transaction. It also serves as an +-- umbrella re-exporting all the automation submodules (auto-filling, balancing +-- and transaction generation). +module Cooked.MockChain.Automation ( runAutomationPipeline, + module X, ) where -import Cooked.MockChain.Automation.AutoFilling.Constitution -import Cooked.MockChain.Automation.AutoFilling.MinAda -import Cooked.MockChain.Automation.AutoFilling.ReferenceScripts -import Cooked.MockChain.Automation.AutoFilling.Withdrawals -import Cooked.MockChain.Automation.Balancing -import Cooked.MockChain.Automation.GenerateTx.Body +import Cooked.MockChain.Automation.AutoFilling.Constitution as X +import Cooked.MockChain.Automation.AutoFilling.MinAda as X +import Cooked.MockChain.Automation.AutoFilling.ReferenceScripts as X +import Cooked.MockChain.Automation.AutoFilling.Withdrawals as X +import Cooked.MockChain.Automation.Balancing as X +import Cooked.MockChain.Automation.GenerateTx.Anchor as X +import Cooked.MockChain.Automation.GenerateTx.Body as X +import Cooked.MockChain.Automation.GenerateTx.Certificate as X +import Cooked.MockChain.Automation.GenerateTx.Collateral as X +import Cooked.MockChain.Automation.GenerateTx.Credential as X +import Cooked.MockChain.Automation.GenerateTx.Input as X +import Cooked.MockChain.Automation.GenerateTx.Mint as X +import Cooked.MockChain.Automation.GenerateTx.Output as X +import Cooked.MockChain.Automation.GenerateTx.Proposal as X +import Cooked.MockChain.Automation.GenerateTx.ReferenceInputs as X +import Cooked.MockChain.Automation.GenerateTx.Withdrawals as X +import Cooked.MockChain.Automation.GenerateTx.Witness as X import Cooked.MockChain.Common import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Read.Chain @@ -71,7 +87,7 @@ runAutomationPipeline txSkel = runTweak txSkel $ do logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals -- We retrieve the extra signatories to add to the transaction signatories <- viewTweak txSkelSignatoriesL - -- We generate the transaction asscoiated with the skeleton, and apply on it + -- We generate the transaction associated with the skeleton, and apply on it -- the modifications from the skeleton options return ( P.Ledger.CardanoEmulatorEraTx $ txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories body, diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs index 8882e95ad..b74009692 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -22,7 +22,7 @@ where import Cardano.Api qualified as Cardano import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad -import Cooked.MockChain.Automation.Pipeline +import Cooked.MockChain.Automation import Cooked.MockChain.Common import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Read.Chain From e2898ffceaf48dc069da0f2cb4f3166ea2601879 Mon Sep 17 00:00:00 2001 From: mmontin Date: Fri, 7 Aug 2026 18:44:07 +0200 Subject: [PATCH 16/18] no more dummy input + clean up forceOutputs --- src/Cooked/MockChain/Effect/Write.hs | 51 +++++++-------------------- src/Cooked/MockChain/Runtime/State.hs | 6 ++++ 2 files changed, 19 insertions(+), 38 deletions(-) diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index 6c27f383e..7b779510f 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -37,7 +37,6 @@ import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton -import Data.Map.Optics (toMapOf) import Data.Map.Strict qualified as Map import Ledger.Index qualified as P.Ledger import Ledger.Orphans () @@ -83,57 +82,33 @@ runMockChainWrite = interpret $ \case modify $ set emulatorStateParamsL params modify $ over emulatorStateLedgerStateL $ Emulator.updateStateParams params WaitNSlots n -> do - cs <- gets (Emulator.getSlot . emulatorStateLedgerState) + cs <- gets $ Emulator.getSlot . emulatorStateLedgerState if | n == 0 -> return cs | n > 0 -> do let newSlot = cs + fromIntegral n - modify' (over emulatorStateLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot) + modify' $ over emulatorStateLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot return newSlot - | otherwise -> throw $ MCEPastSlot cs (cs + fromIntegral n) + | otherwise -> throw $ MCEPastSlot cs $ cs + fromIntegral n SetConstitutionScript (toVScript -> cScript) -> do - modify' (chainIndexConstitutionL ?~ cScript) + modify' $ chainIndexConstitutionL ?~ cScript modify' $ over emulatorStateLedgerStateL $ - Lens.set Emulator.elsConstitutionScriptL $ - (Cardano.SJust . Cardano.toShelleyScriptHash . Script.toCardanoScriptHash) - cScript + Lens.set + Emulator.elsConstitutionScriptL + (Cardano.SJust $ Cardano.toShelleyScriptHash $ Script.toCardanoScriptHash cScript) ForceOutputs outputs -> do - -- We retrieve the protocol parameters - params <- getParams - -- We retrieve the network id - networkId <- getNetworkId -- We adjust the outputs for the minimal required ADA if needed outputsMinAda <- mapM toTxSkelOutWithMinAda outputs -- We transform these outputs to Cardano outputs outputs' <- mapM toCardanoTxOut outputsMinAda - -- We create our transaction body, which only consists of the dummy input - -- and the outputs to force, and make a transaction out of it. + -- We create our transaction body, composed of the forced outputs cardanoTx <- P.Ledger.CardanoEmulatorEraTx . (`Cardano.Tx` []) - <$> txBodyContentToTxBody - ( P.Ledger.emptyTxBodyContent - { Cardano.txOuts = outputs', - -- The emulator takes for granted transactions with a single pseudo input, - -- which we build to force transaction validation - Cardano.txIns = - [ ( Cardano.genesisUTxOPseudoTxIn networkId $ - Cardano.GenesisUTxOKeyHash $ - Cardano.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194", - Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending - ) - ], - Cardano.txProtocolParams = Cardano.BuildTxWith . Just . Cardano.LedgerProtocolParameters $ params - } - ) + <$> txBodyContentToTxBody (P.Ledger.emptyTxBodyContent {Cardano.txOuts = outputs'}) -- We need to adjust our internal state to account for the forced - -- transaction. We begin by computing the new map of outputs. - let outputsMap = - Map.fromList $ - zipWith - (\x y -> (x, (y, True))) - (P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx) - outputsMinAda + -- transaction. We begin by computing the new outputs. + let outputsList = zip (P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx) outputsMinAda -- We update the index, which effectively receives the new utxos modify' $ over emulatorStateLedgerStateL $ @@ -142,9 +117,9 @@ runMockChainWrite = interpret $ \case . P.Ledger.insert cardanoTx . P.Ledger.toPlutusIndex -- We update our internal map by adding the new outputs - modify' $ over chainIndexOutputsL (<> outputsMap) + modify' $ addOutputs outputsList -- Finally, we return the created utxos - return $ toMapOf (itraversed % to fst) outputsMap + return $ Map.fromList outputsList -- | Waits a certain number of slots and returns the new slot waitNSlots :: (Member MockChainWrite effs) => Integer -> Sem effs P.Ledger.Slot diff --git a/src/Cooked/MockChain/Runtime/State.hs b/src/Cooked/MockChain/Runtime/State.hs index b1a881170..acc3bee03 100644 --- a/src/Cooked/MockChain/Runtime/State.hs +++ b/src/Cooked/MockChain/Runtime/State.hs @@ -34,6 +34,7 @@ module Cooked.MockChain.Runtime.State -- * Helpers to add or remove outputs from a `ChainIndex` addOutput, + addOutputs, removeOutput, -- * `UtxoState`: A simplified, address-focused view on a `ChainIndex` @@ -129,6 +130,11 @@ chainIndexMOutputL oRef = chainIndexOutputsL % at oRef % iso (fmap fst) (fmap (, addOutput :: Api.TxOutRef -> TxSkelOut -> ChainIndex -> ChainIndex addOutput oRef = set (chainIndexMOutputL oRef) . Just +-- | Stores a list of outputs in a 'ChainIndex' +addOutputs :: [(Api.TxOutRef, TxSkelOut)] -> ChainIndex -> ChainIndex +addOutputs outputs chainIndex = + foldl (\index (oRef, output) -> addOutput oRef output index) chainIndex outputs + -- | Removes an output from the 'ChainIndex'. This does not actually remove -- it from the map, but instead marks its availability to @False@ removeOutput :: Api.TxOutRef -> ChainIndex -> ChainIndex From 490aba7120efe290c393cb6694319d092915dc1a Mon Sep 17 00:00:00 2001 From: mmontin Date: Sat, 8 Aug 2026 01:07:03 +0200 Subject: [PATCH 17/18] fixing missing doc' --- src/Cooked/MockChain/UtxoSearch.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index 248bcf638..38ac57998 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/MockChain/UtxoSearch.hs @@ -61,6 +61,7 @@ import PlutusLedgerApi.V3 qualified as Api import Polysemy import Witherable +-- | An heterogeneous list starting with a 'TxSkelOut' type RefinedOutputsList elems = HList (TxSkelOut ': elems) -- | Raw result of a `UtxoSearch`. We store the `Api.TxOutRef` of the output, From c6d00abe961939e0a735512bd66a687bec298c44 Mon Sep 17 00:00:00 2001 From: mmontin Date: Mon, 10 Aug 2026 00:58:41 +0200 Subject: [PATCH 18/18] WIP --- cooked-validators.cabal | 1 + package.yaml | 1 + src/Cooked/MockChain/Automation.hs | 57 ++-- .../Automation/AutoFilling/Constitution.hs | 21 +- src/Cooked/MockChain/Automation/Balancing.hs | 100 +++++-- .../MockChain/Automation/GenerateTx/Body.hs | 149 ++++++----- src/Cooked/MockChain/Effect/Validation.hs | 247 ++++++++++-------- src/Cooked/Skeleton/Option.hs | 44 ++-- src/Cooked/Skeleton/Proposal.hs | 6 +- 9 files changed, 361 insertions(+), 265 deletions(-) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 21d10974e..b4245fb7f 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -141,6 +141,7 @@ library , data-default , either , exceptions + , extra , http-conduit , lens , microlens diff --git a/package.yaml b/package.yaml index 604a003f8..28763733d 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ library: - data-default - either - exceptions + - extra - http-conduit - lens - microlens diff --git a/src/Cooked/MockChain/Automation.hs b/src/Cooked/MockChain/Automation.hs index 8c60e5cd2..c43c78a7b 100644 --- a/src/Cooked/MockChain/Automation.hs +++ b/src/Cooked/MockChain/Automation.hs @@ -8,6 +8,7 @@ module Cooked.MockChain.Automation ) where +import Control.Monad import Cooked.MockChain.Automation.AutoFilling.Constitution as X import Cooked.MockChain.Automation.AutoFilling.MinAda as X import Cooked.MockChain.Automation.AutoFilling.ReferenceScripts as X @@ -25,30 +26,27 @@ import Cooked.MockChain.Automation.GenerateTx.Proposal as X import Cooked.MockChain.Automation.GenerateTx.ReferenceInputs as X import Cooked.MockChain.Automation.GenerateTx.Withdrawals as X import Cooked.MockChain.Automation.GenerateTx.Witness as X -import Cooked.MockChain.Common import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.Skeleton import Cooked.Tweak.Common -import Cooked.Tweak.Query -import Cooked.Tweak.Update import Ledger.Orphans () import Ledger.Tx qualified as P.Ledger -import Optics.Core import Polysemy import Polysemy.Error import Polysemy.Fail --- | This runs the full automation pipeline, in that order: +-- | This runs the full automation pipeline: -- 1. autofill min ada on eligible outputs -- 2. autofill constution on eligible proposals -- 3. autofill reference inputs on eligible redeemers -- 4. autofill amount on eligible withdrawals --- 5. balance the skeleton according to the inner options --- 6. generate the transaction associated with the balanced skeleton --- It logs relevant events in the process, and returns the transaction. +-- 5. balance the skeleton +-- 6. compute fees and collaterals +-- 7. generate a cardano transaction body +-- 8. fetch phase 2 failures runAutomationPipeline :: ( Members '[ Error P.Ledger.ToCardanoError, @@ -61,36 +59,13 @@ runAutomationPipeline :: effs ) => TxSkel -> - Sem effs (TxSkel, (P.Ledger.CardanoTx, Maybe Collaterals, Fee)) -runAutomationPipeline txSkel = runTweak txSkel $ do - -- We log the submission of the new skeleton - viewTweak simple >>= logEvent . MCLogSubmittedTxSkel - -- We retrieve the current skeleton options - TxSkelOpts {..} <- viewTweak txSkelOptsL - -- We ensure that the outputs have the required minimal amount of ada, when - -- requested in the skeleton options - autoFillMinAda - -- We retrieve the official constitution script and attach it to each - -- proposal that requires it, if it's not empty - 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 - autoFillReferenceScripts - -- We attach the reward amount to withdrawals when applicable - autoFillWithdrawalAmounts - -- We balance the skeleton when requested in the skeleton option, and get - -- the associated fee, collateral inputs and return collateral user - ExtendedTxSkel finalTxSkel fee mCollaterals body <- viewTweak simple >>= balanceTxSkel - -- We store the balanced skeleton - setTweak simple finalTxSkel - -- We log the balanced skeleton - logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals - -- We retrieve the extra signatories to add to the transaction - signatories <- viewTweak txSkelSignatoriesL - -- We generate the transaction associated with the skeleton, and apply on it - -- the modifications from the skeleton options - return - ( P.Ledger.CardanoEmulatorEraTx $ txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories body, - mCollaterals, - fee - ) + Sem effs ExtendedTxSkel +runAutomationPipeline = + ( `execTweak` + do + autoFillMinAda + autoFillConstitution + autoFillReferenceScripts + autoFillWithdrawalAmounts + ) + >=> balanceTxSkel diff --git a/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs b/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs index 53f17fd65..e26e33b62 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs +++ b/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs @@ -7,6 +7,7 @@ module Cooked.MockChain.Automation.AutoFilling.Constitution where import Control.Monad +import Control.Monad.Extra import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Read.Chain import Cooked.Skeleton @@ -23,16 +24,22 @@ import Polysemy -- existing specified script in such proposals. Logs an event when the -- constitution script has been successfully auto-filled. autoFillConstitution :: - (Members '[MockChainReadChain, Tweak, MockChainLog] effs) => + ( Members + '[ MockChainReadChain, + Tweak, + MockChainLog + ] + effs + ) => Sem effs () autoFillConstitution = do - currentConstitution <- getConstitutionScript - case currentConstitution of - Nothing -> return () - Just constitutionScript -> do - traverseTweak (txSkelProposalsL % traversed) $ \prop -> do + maybeM + (return ()) + ( \constitutionScript -> traverseTweak (txSkelProposalsL % traversed) $ \prop -> do when (isn't txSkelProposalConstitutionAT prop) $ logEvent $ MCLogAutoFilledConstitution $ Script.toScriptHash constitutionScript - return (fillConstitution constitutionScript prop) + return (fillConstitutionWhenEmpty constitutionScript prop) + ) + getConstitutionScript diff --git a/src/Cooked/MockChain/Automation/Balancing.hs b/src/Cooked/MockChain/Automation/Balancing.hs index 45a23f38b..bf58751dc 100644 --- a/src/Cooked/MockChain/Automation/Balancing.hs +++ b/src/Cooked/MockChain/Automation/Balancing.hs @@ -2,8 +2,7 @@ -- computation of fees and collaterals because their computation cannot be -- separated from the balancing. module Cooked.MockChain.Automation.Balancing - ( Body, - ExtendedTxSkel (..), + ( ExtendedTxSkel (..), balanceTxSkel, getMinAndMaxFee, estimateTxSkelFee, @@ -26,7 +25,7 @@ import Cooked.MockChain.Runtime.Error import Cooked.MockChain.UtxoSearch import Cooked.Skeleton import Data.ByteString qualified as BS -import Data.List (find) +import Data.Foldable.Extra import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Ratio qualified as Rat @@ -45,10 +44,7 @@ import Polysemy import Polysemy.Error import Polysemy.Fail --- | A transaction body -type Body = Cardano.TxBody Cardano.ConwayEra - --- | A `TxSkel` with extra pieces of information produced during balancing +-- | A 'TxSkel' with extra pieces of information produced during balancing data ExtendedTxSkel = ExtendedTxSkel { -- | The skeleton itself eSkel :: TxSkel, @@ -57,7 +53,9 @@ data ExtendedTxSkel = ExtendedTxSkel -- | The optional collaterals associated with this skeleton eMCollaterals :: Maybe Collaterals, -- | The Cardano body generated from this skeleton - eBody :: Body + eBody :: Body, + -- | The script errors uncovered during body generation + eScriptErrors :: ScriptErrors } -- | This is the main entry point of our balancing mechanism. This function @@ -67,7 +65,16 @@ data ExtendedTxSkel = ExtendedTxSkel -- skeleton control whether it should be balanced, and how to compute its -- associated elements. balanceTxSkel :: - (Members '[MockChainReadChain, MockChainReadConf, MockChainLog, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + MockChainLog, + Error MockChainError, + Error P.Ledger.ToCardanoError, + Fail + ] + effs + ) => TxSkel -> Sem effs ExtendedTxSkel balanceTxSkel skelUnbal@TxSkel {..} = do @@ -125,8 +132,8 @@ balanceTxSkel skelUnbal@TxSkel {..} = do AutoFeeComputation -> maxFee ManualFee fee' -> fee' mCols <- collateralsFromFee fee mCollaterals - cBody <- txSkelToTxBody skelUnbal fee mCols - return $ ExtendedTxSkel skelUnbal fee mCols cBody + (cBody, cScriptErrors) <- txSkelToTxBody skelUnbal fee mCols + return $ ExtendedTxSkel skelUnbal fee mCols cBody cScriptErrors Just bUser -> do -- The balancing should be performed. We collect the candidates balancing -- utxos based on the associated policy @@ -153,8 +160,8 @@ balanceTxSkel skelUnbal@TxSkel {..} = do ManualFee fee -> do mCols <- collateralsFromFee fee mCollaterals balancedSkel <- computeBalancedTxSkel bUser balancingUtxos skelUnbal fee - cBody <- txSkelToTxBody balancedSkel fee mCols - return $ ExtendedTxSkel balancedSkel fee mCols cBody + (cBody, cScriptErrors) <- txSkelToTxBody balancedSkel fee mCols + return $ ExtendedTxSkel balancedSkel fee mCols cBody cScriptErrors where filterAndWarn f s l | (ok, toInteger . length -> koLength) <- Map.partitionWithKey f l = @@ -163,7 +170,15 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- | Computes optimal fee for a given skeleton and balances it around those fees. -- This uses a dichotomic search for an optimal "balanceable around" fee. computeFeeAndBalance :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error MockChainError, + Error P.Ledger.ToCardanoError, + Fail + ] + effs + ) => Peer -> Fee -> Fee -> @@ -182,11 +197,15 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske ( do newSkel <- computeBalancedTxSkel balancingUser balancingUtxos skel fee mCols <- collateralsFromFee fee mCollaterals - (newFee, body) <- estimateTxSkelFee newSkel fee mCols + (newFee, body, sErrors) <- estimateTxSkelFee newSkel fee mCols if + -- The skeleton was balanceable. However, there were some phase 2 + -- errors uncovered during body generation, and the skeleton options + -- require to stop balancing immediately in this case. + | notNull sErrors && not (view (txSkelOptsL % txSkelOptOptimizeFeeInCaseOfScriptFailuresL) skel) -> return $ ExtendedTxSkel newSkel newFee mCols body sErrors -- The skeleton was balanceable, we cannot try smaller fee, but -- the used fee is sufficient for the generated body - | minFee == maxFee && newFee <= fee -> return $ ExtendedTxSkel newSkel newFee mCols body + | minFee == maxFee && newFee <= fee -> return $ ExtendedTxSkel newSkel newFee mCols body sErrors -- The skeleton was balanceable, we cannot try smaller fee, but -- the used fee is insufficient for the generated body | minFee == maxFee -> throw $ MCEBalancingError $ NotEnoughFundForProperFee balancingUser @@ -220,7 +239,14 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske -- min ada requirements in the associated return collateral and the maximum -- number of collateral inputs authorized by protocol parameters. collateralsFromFee :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error MockChainError, + Error P.Ledger.ToCardanoError + ] + effs + ) => -- | The fee from which these collaterals should be computed Fee -> -- | The optional candidate UTxOs to be used as collaterals, alongside the @@ -256,7 +282,13 @@ collateralsFromFee fee (Just (collateralIns, returnCollateralUser)) = do reachValue :: forall effs. - (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error P.Ledger.ToCardanoError + ] + effs + ) => -- | The Utxos available to reach the value Utxos -> -- | The target value to reach @@ -390,30 +422,45 @@ reachValue (Map.toList -> utxos) target fuel outputOrUser = do -- | Estimates the required fee for a given skeleton with a given initial fee -- and collaterals estimateTxSkelFee :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error MockChainError, + Error P.Ledger.ToCardanoError, + Fail + ] + effs + ) => TxSkel -> Fee -> Maybe Collaterals -> - Sem effs (Fee, Body) + Sem effs (Fee, Body, ScriptErrors) estimateTxSkelFee skel fee mCollaterals = do -- We retrieve the necessary data to generate the transaction body params <- getParams -- We build the index known to the skeleton index <- txSkelToIndex skel mCollaterals -- We build the transaction body - txBody <- txSkelToTxBody skel fee mCollaterals + (txBody, scriptErrors) <- txSkelToTxBody skel fee mCollaterals -- We retrieve the amount of signatories let nbOfSignatories = fromIntegral $ length $ txSkelSignatories skel -- We compute the estimated fee let Cardano.Coin newFee = Cardano.calculateMinTxFee Cardano.ShelleyBasedEraConway params index txBody nbOfSignatories -- We return both the new fee and generated body - return (newFee, txBody) + return (newFee, txBody, scriptErrors) -- | This creates a balanced skeleton from a given skeleton and fee. In other -- words, this ensures that the following equation holds: input value + minted -- value + withdrawn value = output value + burned value + fee + deposits computeBalancedTxSkel :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error MockChainError, + Error P.Ledger.ToCardanoError + ] + effs + ) => Peer -> Utxos -> TxSkel -> @@ -497,7 +544,12 @@ computeBalancedTxSkel balancingUser balancingUtxos txSkel@TxSkel {..} (Script.lo -- See https://github.com/IntersectMBO/cardano-ledger/blob/master/docs/adr/2024-08-14_009-refscripts-fee-change.md -- for more information getMinAndMaxFee :: - (Members '[MockChainReadChain, MockChainReadConf] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf + ] + effs + ) => Integer -> Sem effs (Fee, Fee) getMinAndMaxFee nbOfScripts = do diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs index e1ac6748e..afc095a54 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs @@ -1,17 +1,21 @@ -- | This modules exposes entry points to convert a 'TxSkel' into a fully -- fledged transaction body module Cooked.MockChain.Automation.GenerateTx.Body - ( txSkelToTxBody, + ( BodyContent, + Body, + ScriptErrors, + Tx, + txSkelToTxBody, txBodyContentToTxBody, txSkelToTxBodyContent, txSkelToIndex, txSignatoriesAndBodyToCardanoTx, - txSkelToCardanoTx, ) where import Cardano.Api qualified as Cardano import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo +import Cardano.Ledger.Conway qualified as Conway import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Certificate import Cooked.MockChain.Automation.GenerateTx.Collateral @@ -28,26 +32,45 @@ import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Runtime.Error import Cooked.Skeleton import Data.Bifunctor (first) +import Data.Map (Map) import Data.Map qualified as Map -import Data.Maybe import Data.Set qualified as Set -import Data.Text qualified as Text import Ledger.Address qualified as P.Ledger -import Ledger.Index qualified as P.Ledger import Ledger.Tx.CardanoAPI qualified as P.Ledger +import Optics.Core import Plutus.Script.Utils.Address qualified as Script -import PlutusLedgerApi.V1 qualified as Api import Polysemy import Polysemy.Error import Polysemy.Fail +import Witherable + +-- | A transaction body content +type BodyContent = Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra + +-- | A transaction body +type Body = Cardano.TxBody Cardano.ConwayEra + +-- | Script errors in a transaction body +type ScriptErrors = Map Cardano.ScriptWitnessIndex (Alonzo.TransactionScriptFailure Conway.ConwayEra) + +-- | A transaction +type Tx = Cardano.Tx Cardano.ConwayEra -- | Generates a body content from a skeleton txSkelToTxBodyContent :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error MockChainError, + Error P.Ledger.ToCardanoError, + Fail + ] + effs + ) => TxSkel -> Fee -> Maybe Collaterals -> - Sem effs (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra) + Sem effs BodyContent txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do txIns <- mapM toTxInAndWitness $ Map.toList txSkelInputs txInsReference <- toInsReference skel @@ -67,10 +90,11 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do txWithdrawals <- toWithdrawals txSkelWithdrawals txCertificates <- toCertificates txSkelCertificates let txFee = Cardano.TxFeeExplicit Cardano.ShelleyBasedEraConway $ Cardano.Coin fee + -- This is filled later on, after computing the execution units + txScriptValidity = Cardano.TxScriptValidityNone txMetadata = Cardano.TxMetadataNone txAuxScripts = Cardano.TxAuxScriptsNone txUpdateProposal = Cardano.TxUpdateProposalNone - txScriptValidity = Cardano.TxScriptValidityNone txVotingProcedures = Nothing txCurrentTreasuryValue = Nothing txTreasuryDonation = Nothing @@ -79,8 +103,8 @@ txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do -- | Generates a transaction body from a body content txBodyContentToTxBody :: (Member (Error P.Ledger.ToCardanoError) effs) => - Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra -> - Sem effs (Cardano.TxBody Cardano.ConwayEra) + BodyContent -> + Sem effs Body txBodyContentToTxBody = fromEither . first (P.Ledger.TxBodyError . Cardano.displayError) @@ -88,7 +112,13 @@ txBodyContentToTxBody = -- | Generates an index with utxos known to a 'TxSkel' txSkelToIndex :: - (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error P.Ledger.ToCardanoError + ] + effs + ) => TxSkel -> Maybe Collaterals -> Sem effs (Cardano.UTxO Cardano.ConwayEra) @@ -102,79 +132,70 @@ txSkelToIndex txSkel mCollaterals = do txOutL <- forM knownTxOuts toCardanoTxOut -- We build the index and handle the possible error txInL <- fromEither $ forM knownTxORefs P.Ledger.toCardanoTxIn + -- We reshape the built index to the right format and return it return $ Cardano.UTxO $ Map.fromList $ zip txInL $ Cardano.toCtxUTxOTxOut <$> txOutL -- | Generates a transaction body from a 'TxSkel' and associated fee and -- collateral information. This transaction body accounts for the actual --- execution units of each of the scripts involved in the skeleton. +-- execution units of each of the scripts involved in the skeleton. During the +-- computation of these execution units, some validation errors can occur, in +-- which case the body will not account for them, but the error maps will be +-- returned. txSkelToTxBody :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + ( Members + '[ MockChainReadChain, + MockChainReadConf, + Error P.Ledger.ToCardanoError, + Error MockChainError, + Fail + ] + effs + ) => TxSkel -> Fee -> Maybe Collaterals -> - Sem effs (Cardano.TxBody Cardano.ConwayEra) + Sem effs (Body, ScriptErrors) txSkelToTxBody txSkel fee mCollaterals = do -- We create a first body content and body, without execution units txBodyContent' <- txSkelToTxBodyContent txSkel fee mCollaterals txBody' <- txBodyContentToTxBody txBodyContent' -- We create a full transaction from the body let (Cardano.ShelleyTx _ tx) = txSignatoriesAndBodyToCardanoTx (txSkelSignatories txSkel) txBody' - -- We retrieve the index and parameters to feed to @getTxExUnitsWithLogs@ + -- We build the index of known utxos index <- txSkelToIndex txSkel mCollaterals + -- We retrieve the parameters params <- getParams + -- We retrieve the @epochInfo@ from the era history epochInfo <- Cardano.unLedgerEpochInfo . Cardano.toLedgerEpochInfo <$> getEraHistory + -- We retrieve the system start systemStart <- getSystemStart - -- We compute the execution units associated with the transaction and process - -- the result by splitting successful cases from errors. + -- We compute the execution units associated with the transaction let exUnitsReport = Alonzo.evalTxExUnits params tx (P.Ledger.fromPlutusIndex index) epochInfo systemStart - (success, errors) = - foldl - ( \(sucs, errs) (purpose, report) -> case report of - Right exUnits -> - ( Map.insert (Cardano.toScriptIndex Cardano.AlonzoEraOnwardsConway purpose) (Cardano.fromAlonzoExUnits exUnits) sucs, - errs - ) - Left err -> - ( success, - ( case err of - Alonzo.ValidationFailure _ (Api.CekError e) logs _ -> P.Ledger.ScriptFailure (Api.EvaluationError logs ("CekEvaluationFailure: " ++ show e)) - e -> P.Ledger.CardanoLedgerValidationError $ Text.pack $ show e - ) - : errs - ) - ) - (Map.empty, []) - (Map.toList exUnitsReport) - -- Computing the execution units can result in all phase 2 validation - -- failures, except for the ones related to the execution units themselves. - case errors of - -- No validation failures detected, we assigne the execution units. - [] -> case Cardano.substituteExecutionUnits success txBodyContent' of - -- This can only be a @TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap@ - Left err -> throw $ MCEFailure $ "Error while assigning execution units: " <> show err - -- We now have a body content with proper execution units and can create - -- the final body from it - Right txBodyContent -> txBodyContentToTxBody txBodyContent - -- Some validation failures detected, and they should be handled - l | not $ txSkelOptDeferPhase2FailuresDuringBalancing $ txSkelOpts txSkel -> throw $ MCEValidationError P.Ledger.Phase2 l - -- Some validation failures detected, which should be deferred. We ignore - -- them and return the current body without assigning execution units. - _ -> return txBody' + -- We transform the keys to Cardano script index + let cExUnitsReport = Map.mapKeysMonotonic (Cardano.toScriptIndex Cardano.AlonzoEraOnwardsConway) exUnitsReport + -- We extract the succesful cases from the map + let executionUnitsMap = mapMaybe (preview (_Right % to Cardano.fromAlonzoExUnits)) cExUnitsReport + -- We also extract the failures + let failuresMap = mapMaybe (preview _Left) cExUnitsReport + -- We attempt to insert the execution units in the body + let (txBodyContent, scriptValid) = + Cardano.substituteExecutionUnits executionUnitsMap txBodyContent' + & either + -- If this fails, this can only be a + -- @TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap@ which means that + -- some scripts failed (@failureMap@ is not empty) in which case we return + -- the original body, and mark the scripts as invalid. + (const (txBodyContent', Cardano.ScriptInvalid)) + -- We now have a body content with proper execution units and can create + -- the final body from it, while marking the scripts as valid. + (,Cardano.ScriptValid) + -- We generate the final tx body from the body content and the script validity + finalTxBody <- txBodyContentToTxBody txBodyContent {Cardano.txScriptValidity = Cardano.TxScriptValidity Cardano.AlonzoEraOnwardsConway scriptValid} + return (finalTxBody, failuresMap) -- | Generates a Cardano transaction and signs it txSignatoriesAndBodyToCardanoTx :: [TxSkelSignatory] -> - Cardano.TxBody Cardano.ConwayEra -> - Cardano.Tx Cardano.ConwayEra + Body -> + Tx txSignatoriesAndBodyToCardanoTx signatories txBody = Cardano.Tx txBody $ mapMaybe (toKeyWitness txBody) signatories - --- | Generates a full Cardano transaction from a skeleton, fees and collaterals -txSkelToCardanoTx :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => - TxSkel -> - Fee -> - Maybe Collaterals -> - Sem effs (Cardano.Tx Cardano.ConwayEra) -txSkelToCardanoTx txSkel fee = - fmap (txSignatoriesAndBodyToCardanoTx (txSkelSignatories txSkel)) - . txSkelToTxBody txSkel fee diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs index b74009692..e552cd827 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -12,6 +12,7 @@ module Cooked.MockChain.Effect.Validation runMockChainValidateNode, -- * Sending `Cooked.Skeleton.TxSkel`s for validation + submitTransaction, validateTxSkel, validateTxSkel', validateTxSkelL, @@ -20,6 +21,9 @@ module Cooked.MockChain.Effect.Validation where import Cardano.Api qualified as Cardano +import Cardano.Ledger.Conway qualified as Conway +import Cardano.Ledger.Conway.Rules qualified as Conway +import Cardano.Ledger.Shelley.API.Mempool qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad import Cooked.MockChain.Automation @@ -44,120 +48,170 @@ import Polysemy.Fail import Polysemy.Reader import Polysemy.State --- | An effect that offers the ability to send a `Cooked.Skeleton.TxSkel` for --- validation on the emulated blockchain. +-- | An effect that offers the ability to submit a transaction for validation, +-- while returning the list of validation failures, if any. data MockChainValidate :: Effect where - ValidateTxSkel :: TxSkel -> MockChainValidate m (P.Ledger.CardanoTx, Utxos) + SubmitTransaction :: Tx -> MockChainValidate m [Conway.ConwayLedgerPredFailure Conway.ConwayEra] makeSem_ ''MockChainValidate --- | Generates, balances and validates a transaction from a skeleton, and --- returns the validated transaction, alongside the created UTxOs. -validateTxSkel :: (Member MockChainValidate effs) => TxSkel -> Sem effs (P.Ledger.CardanoTx, Utxos) +submitTransaction :: (Member MockChainValidate effs) => Tx -> Sem effs [Conway.ConwayLedgerPredFailure Conway.ConwayEra] + +-- | Generates, balances and validates a transaction from a skeleton +validateTxSkel :: + ( Members + '[ MockChainValidate, + MockChainLog, + MockChainReadChain, + MockChainReadConf, + Error P.Ledger.ToCardanoError, + Error MockChainError, + Fail + ] + effs + ) => + TxSkel -> + Sem effs (Tx, Utxos) +validateTxSkel txSkel = do + -- We fetch the skeleton options + let TxSkelOpts {..} = txSkelOpts txSkel + -- We log the submission of the new skeleton + logEvent $ MCLogSubmittedTxSkel txSkel + -- We run the automation pipeline on the original skeleton + ExtendedTxSkel finalTxSkel fee mCollaterals txBody valErrorsExUnits <- runAutomationPipeline txSkel + -- We log the adjusted skeleton + logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals + -- We retrieve the extra signatories to add to the transaction + let signatories = view txSkelSignatoriesL finalTxSkel + -- We build the Cardano transaction + let cardanoTx = txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories txBody + -- We wrap it for plutus-ledger usage + let pCardanoTx = P.Ledger.CardanoTx cardanoTx Cardano.ShelleyBasedEraConway + -- We submit the transaction for validation + valErrorsSubmission <- submitTransaction cardanoTx + -- newOutputs <- case of + -- -- In case of a phase 1 error, we give back the same index + -- (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 [err] + -- (newELedgerState, P.Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do + -- -- We update the emulated ledger state + -- modify' $ set emulatorStateLedgerStateL newELedgerState + -- -- We remove the collateral utxos from our own stored outputs + -- forM_ colInputs $ modify' . removeOutput + -- -- We add the returned collateral to our outputs when it exists + -- case (mRetColOutput, Map.toList $ P.Ledger.getCardanoTxProducedReturnCollateral cardanoTx) of + -- (Nothing, []) -> return () + -- (Just retColOutput, [(txIn, _)]) -> modify' $ addOutput (P.Ledger.fromCardanoTxIn txIn) retColOutput + -- _ -> fail "Unreachable case when processing return collaterals, please report a bug at https://github.com/tweag/cooked-validators/issues" + -- -- We throw a mockchain error + -- throw $ MCEValidationError P.Ledger.Phase2 [err] + -- -- In case of success, we update the index with all inputs and outputs + -- -- contained in the transaction + -- (newELedgerState, P.Ledger.Success {}) -> do + -- -- We retrieve the utxos created by the transaction + -- let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx + -- -- We combine them with their corresponding `TxSkelOut` + -- let newOutputs = zip utxos (txSkelOutputs finalTxSkel) + -- -- We add the news utxos to the state + -- forM_ newOutputs $ modify' . uncurry addOutput + -- -- And remove the old ones + -- forM_ (Map.toList $ txSkelInputs finalTxSkel) $ modify' . removeOutput . fst + -- -- We return the newly created outputs + -- return $ Map.fromList newOutputs + -- -- This is a theoretical unreachable case. Since we fail in Phase 2, it + -- -- means the transaction involved script, and thus we must have generated + -- -- collaterals. + -- (_, P.Ledger.FailPhase2 {}) + -- | Nothing <- mCollaterals -> + -- fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" + -- -- We increase the slot number + -- modify' $ over emulatorStateLedgerStateL Emulator.nextSlot + -- -- We log the validated transaction + logEvent $ + MCLogNewTx + (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId pCardanoTx) + (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs pCardanoTx) + -- We return the validated transaction + return (cardanoTx, newOutputs) -- | Same as `validateTxSkel`, but only returns the generated UTxOs -validateTxSkel' :: (Member MockChainValidate effs) => TxSkel -> Sem effs Utxos +validateTxSkel' :: + ( Members + '[ MockChainValidate, + MockChainLog, + MockChainReadChain, + MockChainReadConf, + Error P.Ledger.ToCardanoError, + Error MockChainError, + Fail + ] + effs + ) => + TxSkel -> + Sem effs Utxos validateTxSkel' = fmap snd . validateTxSkel -- | Same as `validateTxSkel`, but only returns the list of 'Api.TxOutRef' -validateTxSkelL :: (Member MockChainValidate effs) => TxSkel -> Sem effs [Api.TxOutRef] +validateTxSkelL :: + ( Members + '[ MockChainValidate, + MockChainLog, + MockChainReadChain, + MockChainReadConf, + Error P.Ledger.ToCardanoError, + Error MockChainError, + Fail + ] + effs + ) => + TxSkel -> + Sem effs [Api.TxOutRef] validateTxSkelL = fmap (Set.toList . Map.keysSet . snd) . validateTxSkel -- | Same as `validateTxSkel`, but discards the returned transaction -validateTxSkel_ :: (Member MockChainValidate effs) => TxSkel -> Sem effs () -validateTxSkel_ = void . validateTxSkel - --- | Interprets the `MockChainValidate` effect on an emulator -runMockChainValidateEmul :: - forall effs a. +validateTxSkel_ :: ( Members - '[ State EmulatorState, - State ChainIndex, - Error P.Ledger.ToCardanoError, - Error MockChainError, + '[ MockChainValidate, MockChainLog, MockChainReadChain, MockChainReadConf, + Error P.Ledger.ToCardanoError, + Error MockChainError, Fail ] effs ) => + TxSkel -> + Sem effs () +validateTxSkel_ = void . validateTxSkel + +-- | Interprets the `MockChainValidate` effect on an emulator +runMockChainValidateEmul :: + forall effs a. + (Member (State EmulatorState) effs) => Sem (MockChainValidate : effs) a -> Sem effs a runMockChainValidateEmul = interpret $ \case - ValidateTxSkel skel -> do - (finalTxSkel, (cardanoTx, mCollaterals, _fee)) <- runAutomationPipeline skel + SubmitTransaction cardanoTx -> do -- To run transaction validation we need a minimal ledger state eLedgerState <- gets emulatorStateLedgerState -- And the emulator params params <- gets emulatorStateParams - -- We finally run the emulated validation. We update our internal state - -- based on the validation result, and throw an error if this fails. If at - -- some point we want to allows mockchain runs with validation errors, the - -- caller will need to catch those errors and do something with them. - newOutputs <- case Emulator.validateCardanoTx params eLedgerState cardanoTx of - -- In case of a phase 1 error, we give back the same index - (_, P.Ledger.FailPhase1 _ err) -> throw $ MCEValidationError P.Ledger.Phase1 [err] - (newELedgerState, P.Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do - -- We update the emulated ledger state - modify' $ set emulatorStateLedgerStateL newELedgerState - -- We remove the collateral utxos from our own stored outputs - forM_ colInputs $ modify' . removeOutput - -- We add the returned collateral to our outputs when it exists - case (mRetColOutput, Map.toList $ P.Ledger.getCardanoTxProducedReturnCollateral cardanoTx) of - (Nothing, []) -> return () - (Just retColOutput, [(txIn, _)]) -> modify' $ addOutput (P.Ledger.fromCardanoTxIn txIn) retColOutput - _ -> fail "Unreachable case when processing return collaterals, please report a bug at https://github.com/tweag/cooked-validators/issues" - -- We throw a mockchain error - throw $ MCEValidationError P.Ledger.Phase2 [err] - -- In case of success, we update the index with all inputs and outputs - -- contained in the transaction - (newELedgerState, P.Ledger.Success {}) -> do - -- We update the index with the utxos consumed and produced by the tx - modify' (set emulatorStateLedgerStateL newELedgerState) - -- We retrieve the utxos created by the transaction - let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx - -- We combine them with their corresponding `TxSkelOut` - let newOutputs = zip utxos (txSkelOutputs finalTxSkel) - -- We add the news utxos to the state - forM_ newOutputs $ modify' . uncurry addOutput - -- And remove the old ones - forM_ (Map.toList $ txSkelInputs finalTxSkel) $ modify' . removeOutput . fst - -- We return the newly created outputs - return $ Map.fromList newOutputs - -- This is a theoretical unreachable case. Since we fail in Phase 2, it - -- means the transaction involved script, and thus we must have generated - -- collaterals. - (_, P.Ledger.FailPhase2 {}) - | Nothing <- mCollaterals -> - fail "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" - -- We increase the slot number - modify' $ over emulatorStateLedgerStateL Emulator.nextSlot - -- We log the validated transaction - logEvent $ - MCLogNewTx - (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) - (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) - -- We return the validated transaction - return (cardanoTx, newOutputs) + -- We run the transaction validation through the emulator + let (newELedgerState, validationResult) = Emulator.validateCardanoTx params eLedgerState $ P.Ledger.CardanoEmulatorEraTx cardanoTx + -- We update the index with the utxos consumed and produced by the tx + modify' $ set emulatorStateLedgerStateL newELedgerState + -- We return the validation result + return undefined -- | Interprets the `MockChainValidate` effect by submitting the generated -- transaction to a deployed node through a `Cardano.LocalNodeConnectInfo` -- (socket path and network id) provided via a `Reader`, running in a stack -- featuring @IO@ (via `Embed`). --- --- NOTE: this is a first sketch. It runs the same adjustment pipeline as the --- emulator interpreter to obtain a balanced Cardano transaction, then submits it --- to the node instead of validating it locally. Several aspects still need to be --- decided (see the open questions raised alongside this implementation). runMockChainValidateNode :: forall effs a. ( Members '[ Embed IO, - Error P.Ledger.ToCardanoError, - Error MockChainError, - MockChainLog, - MockChainReadChain, + Error Cardano.EraMismatch, MockChainReadConf, Reader Cardano.LocalNodeConnectInfo, Fail @@ -167,31 +221,18 @@ runMockChainValidateNode :: Sem (MockChainValidate : effs) a -> Sem effs a runMockChainValidateNode = interpret $ \case - ValidateTxSkel skel -> do - -- We run the whole adjustment pipeline to obtain a balanced Cardano - -- transaction, exactly like the emulator interpreter does. - (finalTxSkel, (cardanoTx, _mCollaterals, _fee)) <- runAutomationPipeline skel + SubmitTransaction cardanoTx -> do -- We retrieve the local node connection info. conn <- ask - -- We unwrap the underlying Cardano transaction to wrap it into a - -- 'Cardano.TxInMode' and submit it to the node. - let P.Ledger.CardanoEmulatorEraTx cTx = cardanoTx - result <- - embed $ - Cardano.submitTxToNodeLocal conn $ - Cardano.TxInMode Cardano.ShelleyBasedEraConway cTx + -- We submit the transaction to the node + result <- embed $ Cardano.submitTxToNodeLocal conn $ Cardano.TxInMode Cardano.ShelleyBasedEraConway cardanoTx + -- We disect the result the node sends us case result of - -- On success we mirror the emulator bookkeeping: we register the newly - -- created outputs and drop the consumed ones from our local state. - Cardano.SubmitSuccess -> do - let utxos = P.Ledger.fromCardanoTxIn . snd <$> P.Ledger.getCardanoTxOutRefs cardanoTx - newOutputs = Map.fromList $ zip utxos (txSkelOutputs finalTxSkel) - logEvent $ - MCLogNewTx - (P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId cardanoTx) - (fromIntegral $ length $ P.Ledger.getCardanoTxOutRefs cardanoTx) - return (cardanoTx, newOutputs) - -- On rejection we currently surface the reason as a plain failure. This - -- should likely be turned into a dedicated 'MockChainError' constructor. - Cardano.SubmitFail reason -> - fail $ "Node rejected the transaction: " <> show reason + Cardano.SubmitFail (Cardano.TxValidationErrorInCardanoMode (Cardano.ShelleyTxValidationError Cardano.ShelleyBasedEraConway (Shelley.ApplyTxError err))) -> + return $ toList err + -- Somehow, the error does not correspond to the proper era, should be unreachable + Cardano.SubmitFail (Cardano.TxValidationErrorInCardanoMode _) -> fail "TxValidationErrorInCardanoMode: Unreachable case" + -- There is an era mismatch between the ledger era and the transaction era + Cardano.SubmitFail (Cardano.TxValidationEraMismatch eraMismatch) -> throw eraMismatch + -- The submission was successful (no phase 1 error) + Cardano.SubmitSuccess -> return [] diff --git a/src/Cooked/Skeleton/Option.hs b/src/Cooked/Skeleton/Option.hs index 519181cd7..fa936a036 100644 --- a/src/Cooked/Skeleton/Option.hs +++ b/src/Cooked/Skeleton/Option.hs @@ -18,7 +18,7 @@ module Cooked.Skeleton.Option txSkelOptFeePolicyL, txSkelOptBalancingUtxosL, txSkelOptCollateralUtxosL, - txSkelOptDeferPhase2FailuresDuringBalancingL, + txSkelOptOptimizeFeeInCaseOfScriptFailuresL, txSkelOptMaxNbOfBalancingUtxosL, -- * Utilities @@ -36,7 +36,12 @@ import Plutus.Script.Utils.Address qualified as Script import PlutusLedgerApi.V3 qualified as Api -- | Set of constraints that need to be satisfied by users in options -type UserConstraints pkh = (Script.ToPubKeyHash pkh, Show pkh, Eq pkh, Typeable pkh) +type UserConstraints pkh = + ( Script.ToPubKeyHash pkh, + Show pkh, + Eq pkh, + Typeable pkh + ) -- | What fee policy to use in the transaction. data FeePolicy @@ -130,20 +135,15 @@ instance Default CollateralUtxos where -- transaction. data TxSkelOpts = TxSkelOpts { -- | Applies an arbitrary modification to a transaction after it has been - -- potentially adjusted and balanced. The name of this option contains - -- /unsafe/ to draw attention to the fact that modifying a transaction at - -- that stage might make it invalid. Still, this offers a hook for being - -- able to alter a transaction in unforeseen ways. It is mostly used to test - -- contracts that have been written for custom PABs. + -- adjusted, balanced and generated. This offers a hook for being able to + -- alter a transaction in unforeseen ways. -- -- One interesting use of this function is to observe a transaction just -- before it is being sent for validation, with -- - -- > txSkelOptModTx = [RawModTx Debug.Trace.traceShowId] - -- - -- The leftmost function in the list is applied first. + -- > txSkelOptModTx = Debug.Trace.traceShowId -- - -- Default is @[]@. + -- Default is @id@. txSkelOptModTx :: Cardano.Tx Cardano.ConwayEra -> Cardano.Tx Cardano.ConwayEra, -- | Whether to balance the transaction or not, and which user should -- provide/reclaim the missing and surplus value. @@ -177,21 +177,19 @@ data TxSkelOpts = TxSkelOpts -- later submission of the transaction. -- -- When set to @False@: the phase 2 validation failures will be caught as - -- early as possible, typically during balancing when the execution units - -- are computed. This will shortcut the whole balancing process which - -- iterates the body generation, and thus increase performances (by 40%). As - -- a result, the balanced `Cooked.Skeleton.TxSkel` will never be computed - -- and thus will be absent from the log, which is the only downside. + -- early as possible, typically during the first successful balancing + -- attempt when the execution units are computed. This will shortcut the + -- dychotomic search and return a balanced, non-optimized, skeleton, which + -- is not going to pass phase 2 validation (only relevant when + -- @txOptFeePolicy == AutoFeeComputation@). -- -- When set to @True@: the phase 2 validation errors will be ignored during -- the balancing process. This will result in a worst performance (40%), but - -- will allow the log to display a balanced version of the failing - -- `Cooked.Skeleton.TxSkel`, which might be useful. Only use this when - -- debugging complicated phase 2 failures which require a precise view of - -- the balanced `Cooked.Skeleton.TxSkel` sent for validation. + -- will allow the log to display an optimial balanced version of the failing + -- `Cooked.Skeleton.TxSkel`, which would not be computed otherwise. -- -- Default is `False` - txSkelOptDeferPhase2FailuresDuringBalancing :: Bool, + txSkelOptOptimizeFeeInCaseOfScriptFailures :: Bool, -- | The optional maximum number of Utxos that can be used during -- balancing. The algorithm which selects Utxos when permorming balancing is -- greedy. In the default use case where the are only a few wallets and @@ -246,7 +244,7 @@ makeLensesFor [("txSkelOptBalancingUtxos", "txSkelOptBalancingUtxosL")] ''TxSkel makeLensesFor [("txSkelOptCollateralUtxos", "txSkelOptCollateralUtxosL")] ''TxSkelOpts -- | Focuses on the deferring of the failures option of a 'TxSkelOpts' -makeLensesFor [("txSkelOptDeferPhase2FailuresDuringBalancing", "txSkelOptDeferPhase2FailuresDuringBalancingL")] ''TxSkelOpts +makeLensesFor [("txSkelOptOptimizeFeeInCaseOfScriptFailures", "txSkelOptOptimizeFeeInCaseOfScriptFailuresL")] ''TxSkelOpts -- | Focuses on the max nb of balancing Utxos option of a 'TxSkelOpts' makeLensesFor [("txSkelOptMaxNbOfBalancingUtxos", "txSkelOptMaxNbOfBalancingUtxosL")] ''TxSkelOpts @@ -260,7 +258,7 @@ instance Default TxSkelOpts where txSkelOptFeePolicy = def, txSkelOptBalancingUtxos = def, txSkelOptCollateralUtxos = def, - txSkelOptDeferPhase2FailuresDuringBalancing = False, + txSkelOptOptimizeFeeInCaseOfScriptFailures = False, txSkelOptMaxNbOfBalancingUtxos = Nothing } diff --git a/src/Cooked/Skeleton/Proposal.hs b/src/Cooked/Skeleton/Proposal.hs index d32d7ee77..e76de3128 100644 --- a/src/Cooked/Skeleton/Proposal.hs +++ b/src/Cooked/Skeleton/Proposal.hs @@ -19,7 +19,7 @@ module Cooked.Skeleton.Proposal simpleProposal, -- * Utilities - fillConstitution, + fillConstitutionWhenEmpty, ) where @@ -225,8 +225,8 @@ simpleProposal cred action = TxSkelProposal cred action Nothing Nothing -- | Sets the constitution script with an empty redeemer. This will not tamper -- with an existing constitution script and redeemer. -fillConstitution :: (ToVScript script, Typeable script) => script -> TxSkelProposal -> TxSkelProposal -fillConstitution constitution = +fillConstitutionWhenEmpty :: (ToVScript script, Typeable script) => script -> TxSkelProposal -> TxSkelProposal +fillConstitutionWhenEmpty constitution = over (txSkelProposalMConstitutionAT @IsScript) (maybe (Just $ UserRedeemedScript constitution emptyTxSkelRedeemer) Just)