From b718bae909add1015d913d0ce122cdff9ef5b359 Mon Sep 17 00:00:00 2001 From: mmontin Date: Mon, 3 Aug 2026 01:14:47 +0200 Subject: [PATCH 01/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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/39] 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) From e6db16c9bcff7236e48cacb4aa0fcbb117e43a68 Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 11 Aug 2026 15:17:21 +0200 Subject: [PATCH 19/39] interpretation of validation --- CHANGELOG.md | 4 + README.md | 2 +- cooked-validators.cabal | 1 + doc/CHEATSHEET.md | 36 +-- src/Cooked/MockChain/Automation/Balancing.hs | 20 +- .../MockChain/Automation/GenerateTx/Body.hs | 24 +- src/Cooked/MockChain/Common.hs | 26 ++ src/Cooked/MockChain/Effect/Log.hs | 24 +- src/Cooked/MockChain/Effect/Submission.hs | 100 +++++++ src/Cooked/MockChain/Effect/Validation.hs | 266 +++++++----------- src/Cooked/MockChain/Run/Instances.hs | 19 +- src/Cooked/MockChain/Runtime/Error.hs | 8 +- src/Cooked/MockChain/Runtime/State.hs | 5 + src/Cooked/MockChain/Testing.hs | 28 +- src/Cooked/Pretty/MockChain.hs | 32 ++- src/Cooked/Pretty/Skeleton.hs | 36 +-- src/Cooked/Skeleton.hs | 22 +- src/Cooked/Skeleton/Option.hs | 113 +++++--- src/Cooked/Tweak/Guard.hs | 4 +- tests/Spec/Attack/DatumHijacking.hs | 6 +- tests/Spec/Attack/DatumTampering.hs | 6 +- tests/Spec/Attack/OutputsReordering.hs | 2 +- tests/Spec/Attack/PeerTampering.hs | 2 +- tests/Spec/Attack/RedeemerTampering.hs | 4 +- tests/Spec/Attack/TokenDuplication.hs | 10 +- tests/Spec/Attack/ValidityTampering.hs | 2 +- tests/Spec/Balancing.hs | 37 ++- tests/Spec/BasicUsage.hs | 8 +- tests/Spec/Certificates.hs | 4 +- tests/Spec/InitialDistribution.hs | 4 +- tests/Spec/InlineDatums.hs | 6 +- tests/Spec/MinAda.hs | 4 +- tests/Spec/MultiPurpose.hs | 10 +- tests/Spec/ProposingScript.hs | 6 +- tests/Spec/ReferenceInputs.hs | 8 +- tests/Spec/ReferenceScripts.hs | 34 +-- tests/Spec/Tweak/Common.hs | 2 +- tests/Spec/Tweak/Labels.hs | 2 +- tests/Spec/Withdrawals.hs | 4 +- 39 files changed, 537 insertions(+), 394 deletions(-) create mode 100644 src/Cooked/MockChain/Effect/Submission.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 98b330600..990dc0295 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ ### Added +- New `txSkelOptProceedAfterValidationFailures` boolean option in `TxSkelOpts` + (with its `txSkelOptProceedAfterValidationFailuresL` optic). When set to + `True`, transaction validation failures no longer abort the mockchain run. + Default is `False`. - 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 diff --git a/README.md b/README.md index 975478802..6795e0318 100644 --- a/README.md +++ b/README.md @@ -146,7 +146,7 @@ handling fees or balancing. 6. Submit the transaction: ``` haskell validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOuts = [bob `receives` Value (Script.ada 10)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } diff --git a/cooked-validators.cabal b/cooked-validators.cabal index b4245fb7f..d76886b48 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -47,6 +47,7 @@ library Cooked.MockChain.Effect.Misc Cooked.MockChain.Effect.Read.Chain Cooked.MockChain.Effect.Read.Conf + Cooked.MockChain.Effect.Submission Cooked.MockChain.Effect.Validation Cooked.MockChain.Effect.Write Cooked.MockChain.Run.Instances diff --git a/doc/CHEATSHEET.md b/doc/CHEATSHEET.md index b1a6265cc..a58e86ec3 100644 --- a/doc/CHEATSHEET.md +++ b/doc/CHEATSHEET.md @@ -466,7 +466,7 @@ options. It is built upon a transaction skeleton template. Each field can then be overridden. ```haskell -myTxSkel = txSkelTemplate +myTxSkel = txSkelEmulatorTemplate { txSkelInputs = ..., txSkelOutputs = ..., txSkelOpts = ..., @@ -496,7 +496,7 @@ Transaction can be signed with one of more wallets. They will both be part of the required and actual signers of the transaction. ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelSignatories = txSkelSignatoriesFromList [wallet 1, ...] ... @@ -513,7 +513,7 @@ myUser1 myUser2 :: MyType myUser1 = ... myUser2 = ... -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelSignatories = signatoryPubKey <$> [myUser1, myUser2, ...] ... @@ -558,7 +558,7 @@ Payments can automatically be adjusted in terms of minimal ADA requirements: Payments are given in the transaction using the `txSkelOutputs` field: ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelOutputs = [party1 `receives` payment1, party2 `receives` payment2, ...] ... @@ -590,7 +590,7 @@ myRedeemer = ## Inputs ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelInputs = Map.fromList [ (txOutRef1, someTxSkelRedeemer red), @@ -610,7 +610,7 @@ txSkelTemplate * Burn a single kind of token for a given minting policy: `burn barPolicy myTxSkelRedeemer "barName" 6` ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelMints = txSkelMintsFromList [ Mint ..., @@ -628,7 +628,7 @@ txSkelTemplate * Within redeemers manually ``withReferenceInput myTxSkelRedeemer myRefInput`` * Additional reference inputs not bound to redeemers: ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelReferenceInputs = Set.fromList [txOutRef1, txOutRef2, ...] ... @@ -642,7 +642,7 @@ also be provided manually. * From first signer (default): ``` -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelSignatories = [signatory1, signatory2], ... @@ -651,7 +651,7 @@ txSkelTemplate * From another wallet: ``` -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelSignatories = [TxSkelSignatory user1 ... , TxSkelSignatory user2 ...], txSkelOpts = def {txSkelOptCollateralUtxos = CollateralUtxosFromUser user2} @@ -661,7 +661,7 @@ txSkelTemplate * From a direct UTxO list (make sure the owner of these utxo sign the transaction): ``` -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelOpts = def {txSkelOptCollateralUtxos = CollateralUtxosFromSet (Set.fromList [txOutRef1, txOutRef2]) user2} ... @@ -695,7 +695,7 @@ do * Using the builtin constructor for proposals. ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelProposals = [ TxSkelProposal @@ -721,7 +721,7 @@ txSkelTemplate * Using smart constructors and (optional) helpers. ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelProposals = [ simpleProposal @@ -746,7 +746,7 @@ redeemer, logging an `MCLogAutoFilledConstitution` event. * Automatic withdrawal of the available rewards ```haskell -txSkelTemplate +txSkelEmulatorTemplate { txSkelWithdrawals = txSkelWithdrawalsFromList [ scriptWithdrawal myWithdrawingScript myTxSkelRedeemer, pubKeyWithdrawal myWithdrawingPubKey, @@ -759,7 +759,7 @@ txSkelTemplate * Manual withdrawal of a certain amount (for testing purposes only) ```haskell - txSkelTemplate + txSkelEmulatorTemplate { txSkelWithdrawals = txSkelWithdrawalsFromList [ Withdrawal (UserPubKey myWithdrawingPeer) (Just $ Api.Lovelace 2_000_000), ... @@ -781,7 +781,7 @@ myCertificateAction2 = DRepUpdate ... corresponds to the kind of allowed user. ```haskell -txSkelTemplate +txSkelEmulatorTemplate { txSkelCertificates = [ TxSkelCertificate myUser myCertificateAction, pubKeyCertificate myPubKey myCertificateAction1, @@ -797,7 +797,7 @@ txSkelTemplate * First signatory (default): ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelSignatories = [signatory1, signatory2] ... @@ -806,7 +806,7 @@ txSkelTemplate * Another signatory: ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelSignatories = [signatory1, signatory2], txSkelOpts = def {txSkelOptBalancingPolicy = BalanceWith (wallet 2)} @@ -817,7 +817,7 @@ txSkelTemplate ### Do not automatically balance ```haskell -txSkelTemplate +txSkelEmulatorTemplate { ... txSkelOpts = def {txSkelOptBalancingPolicy = DoNotBalance} ... diff --git a/src/Cooked/MockChain/Automation/Balancing.hs b/src/Cooked/MockChain/Automation/Balancing.hs index bf58751dc..c041f9680 100644 --- a/src/Cooked/MockChain/Automation/Balancing.hs +++ b/src/Cooked/MockChain/Automation/Balancing.hs @@ -55,7 +55,7 @@ data ExtendedTxSkel = ExtendedTxSkel -- | The Cardano body generated from this skeleton eBody :: Body, -- | The script errors uncovered during body generation - eScriptErrors :: ScriptErrors + eExUnitsFailures :: ExUnitsFailures } -- | This is the main entry point of our balancing mechanism. This function @@ -132,8 +132,8 @@ balanceTxSkel skelUnbal@TxSkel {..} = do AutoFeeComputation -> maxFee ManualFee fee' -> fee' mCols <- collateralsFromFee fee mCollaterals - (cBody, cScriptErrors) <- txSkelToTxBody skelUnbal fee mCols - return $ ExtendedTxSkel skelUnbal fee mCols cBody cScriptErrors + (cBody, cExUnitsFailures) <- txSkelToTxBody skelUnbal fee mCols + return $ ExtendedTxSkel skelUnbal fee mCols cBody cExUnitsFailures Just bUser -> do -- The balancing should be performed. We collect the candidates balancing -- utxos based on the associated policy @@ -160,8 +160,8 @@ balanceTxSkel skelUnbal@TxSkel {..} = do ManualFee fee -> do mCols <- collateralsFromFee fee mCollaterals balancedSkel <- computeBalancedTxSkel bUser balancingUtxos skelUnbal fee - (cBody, cScriptErrors) <- txSkelToTxBody balancedSkel fee mCols - return $ ExtendedTxSkel balancedSkel fee mCols cBody cScriptErrors + (cBody, cExUnitsFailures) <- txSkelToTxBody balancedSkel fee mCols + return $ ExtendedTxSkel balancedSkel fee mCols cBody cExUnitsFailures where filterAndWarn f s l | (ok, toInteger . length -> koLength) <- Map.partitionWithKey f l = @@ -199,10 +199,6 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske mCols <- collateralsFromFee fee mCollaterals (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 sErrors @@ -434,20 +430,20 @@ estimateTxSkelFee :: TxSkel -> Fee -> Maybe Collaterals -> - Sem effs (Fee, Body, ScriptErrors) + Sem effs (Fee, Body, ExUnitsFailures) 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, scriptErrors) <- txSkelToTxBody skel fee mCollaterals + (txBody, exUnitsFailures) <- 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, scriptErrors) + return (newFee, txBody, exUnitsFailures) -- | This creates a balanced skeleton from a given skeleton and fee. In other -- words, this ensures that the following equation holds: input value + minted diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs index afc095a54..663ab7f2d 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/Automation/GenerateTx/Body.hs @@ -1,11 +1,7 @@ -- | This modules exposes entry points to convert a 'TxSkel' into a fully -- fledged transaction body module Cooked.MockChain.Automation.GenerateTx.Body - ( BodyContent, - Body, - ScriptErrors, - Tx, - txSkelToTxBody, + ( txSkelToTxBody, txBodyContentToTxBody, txSkelToTxBodyContent, txSkelToIndex, @@ -15,7 +11,6 @@ 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 @@ -32,7 +27,6 @@ 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.Set qualified as Set import Ledger.Address qualified as P.Ledger @@ -44,18 +38,6 @@ 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 @@ -154,7 +136,7 @@ txSkelToTxBody :: TxSkel -> Fee -> Maybe Collaterals -> - Sem effs (Body, ScriptErrors) + Sem effs (Body, ExUnitsFailures) txSkelToTxBody txSkel fee mCollaterals = do -- We create a first body content and body, without execution units txBodyContent' <- txSkelToTxBodyContent txSkel fee mCollaterals @@ -197,5 +179,5 @@ txSkelToTxBody txSkel fee mCollaterals = do txSignatoriesAndBodyToCardanoTx :: [TxSkelSignatory] -> Body -> - Tx + Transaction txSignatoriesAndBodyToCardanoTx signatories txBody = Cardano.Tx txBody $ mapMaybe (toKeyWitness txBody) signatories diff --git a/src/Cooked/MockChain/Common.hs b/src/Cooked/MockChain/Common.hs index ccd0f7d83..158d9168e 100644 --- a/src/Cooked/MockChain/Common.hs +++ b/src/Cooked/MockChain/Common.hs @@ -6,9 +6,18 @@ module Cooked.MockChain.Common Collaterals, Utxo, Utxos, + BodyContent, + Body, + Transaction, + SubmissionFailures, + ExUnitsFailures, ) where +import Cardano.Api qualified as Cardano +import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo +import Cardano.Ledger.Conway qualified as Conway +import Cardano.Ledger.Conway.Rules qualified as Conway import Cooked.Skeleton.Output import Data.Map (Map) import Data.Set (Set) @@ -31,3 +40,20 @@ type Utxo = (Api.TxOutRef, TxSkelOut) -- | An alias for lists of `Utxo` type Utxos = Map Api.TxOutRef TxSkelOut + +-- | An alias for a transaction body content +type BodyContent = Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra + +-- | An alias for a transaction body +type Body = Cardano.TxBody Cardano.ConwayEra + +-- | An alias for errors occurring when computing execution units. These contain +-- Phase2 failures, but also errors uncovered when building a proper context to +-- execute the scripts. +type ExUnitsFailures = Map Cardano.ScriptWitnessIndex (Alonzo.TransactionScriptFailure Conway.ConwayEra) + +-- | An alias for errors occurring at submission +type SubmissionFailures = [Conway.ConwayLedgerPredFailure Conway.ConwayEra] + +-- | An alias for a Cardano transaction +type Transaction = Cardano.Tx Cardano.ConwayEra diff --git a/src/Cooked/MockChain/Effect/Log.hs b/src/Cooked/MockChain/Effect/Log.hs index 4c03d113d..b270bb90d 100644 --- a/src/Cooked/MockChain/Effect/Log.hs +++ b/src/Cooked/MockChain/Effect/Log.hs @@ -8,6 +8,7 @@ -- user's perspective, use `Cooked.MockChain.Effect.Misc.note` instead. module Cooked.MockChain.Effect.Log ( -- * Logging events + TxValidity (..), MockChainLogEntry (..), -- * Logging effect @@ -26,6 +27,17 @@ import PlutusLedgerApi.V3 qualified as Api import Polysemy import Polysemy.Writer +-- | The validity of a transaction +data TxValidity + = -- | The transaction is valid, we store the number of inputs and outputs + Valid Int Int + | -- | The transaction is invalid in phase 1 (no ledger change) + InvalidPhase1 + | -- | The transaction is invalid in phase 2, we store the number of collateral + -- inputs and return collateral outputs + InvalidPhase2 Int Int + deriving (Show) + -- | Events logged when processing transaction skeletons data MockChainLogEntry = -- | Logging a Skeleton as it is submitted by the user. @@ -33,9 +45,9 @@ data MockChainLogEntry | -- | Logging a Skeleton as it has been adjusted by the balancing mechanism, -- alongside fee, and possible collateral utxos and return collateral user. MCLogAdjustedTxSkel TxSkel Fee (Maybe Collaterals) - | -- | Logging the successful validation of a new transaction, with its id and - -- number of produced outputs. - MCLogNewTx Api.TxId Integer + | -- | Logging the production of a new transaction, with its ID as well as its + -- validity. + MCLogNewTx Api.TxId TxValidity | -- | Logging the fact that utxos provided by the user for balancing have to be -- discarded for a specific reason. MCLogDiscardedUtxos Integer String @@ -52,6 +64,12 @@ data MockChainLogEntry MCLogAutoFilledConstitution Api.ScriptHash | -- | Logging the automatic adjustment of a min ada amount MCLogAdjustedTxSkelOut TxSkelOut Api.Lovelace + | -- | Logging the existence of failures uncovered during the computation of + -- execution units, when they're not treated as fatal. + MCELogExUnitsFailures ExUnitsFailures + | -- | Logging the existence of failures uncovered during submission, when + -- they're not treated as fatal. + MCELogSubmissionFailures SubmissionFailures deriving (Show) -- | An effect to allow logging of mockchain events diff --git a/src/Cooked/MockChain/Effect/Submission.hs b/src/Cooked/MockChain/Effect/Submission.hs new file mode 100644 index 000000000..5529630e2 --- /dev/null +++ b/src/Cooked/MockChain/Effect/Submission.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module exposes the 'MockChainSubmit' effect, which is responsible for +-- submitting a Cardano transaction for validation. +module Cooked.MockChain.Effect.Submission + ( -- * The 'MockChainSubmit' effect + MockChainSubmit (..), + submitTransaction, + + -- * Interpretation functions + runMockChainSubmitEmul, + runMockChainSubmitNode, + ) +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 Cooked.MockChain.Common +import Cooked.MockChain.Effect.Read.Conf +import Cooked.MockChain.Runtime.State +import Data.Foldable.Extra +import Ledger.Orphans () +import Optics.Core +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.Reader +import Polysemy.State + +data MockChainSubmit :: Effect where + SubmitTransaction :: Transaction -> MockChainSubmit m SubmissionFailures + +makeSem_ ''MockChainSubmit + +-- | Submits a transaction for validation, returning a (possibly empty) list of +-- submission failures. +submitTransaction :: + (Member MockChainSubmit effs) => + Transaction -> + Sem effs [Conway.ConwayLedgerPredFailure Conway.ConwayEra] + +-- | Interprets the `MockChainSubmit` effect on an emulator +runMockChainSubmitEmul :: + forall effs a. + (Member (State EmulatorState) effs) => + Sem (MockChainSubmit : effs) a -> + Sem effs a +runMockChainSubmitEmul = interpret $ \case + SubmitTransaction cardanoTx -> do + -- To run transaction validation we need a minimal ledger state + eLedgerState <- gets emulatorStateLedgerState + -- And the emulator params + params <- gets emulatorStateParams + -- We run the transaction validation through the emulator + let (newELedgerState, submissionFailures) = case Emulator.validateAndApplyTx params eLedgerState cardanoTx of + Left (Shelley.ApplyTxError errs) -> (newELedgerState, toList errs) + Right (newELedgerState', _) -> (newELedgerState', []) + -- We update the index with the utxos consumed and produced by the tx + modify' $ set emulatorStateLedgerStateL newELedgerState + -- We return the validation result + return submissionFailures + +-- | Interprets the `MockChainSubmit` 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`). +runMockChainSubmitNode :: + forall effs a. + ( Members + '[ Embed IO, + Error Cardano.EraMismatch, + MockChainReadConf, + Reader Cardano.LocalNodeConnectInfo, + Fail + ] + effs + ) => + Sem (MockChainSubmit : effs) a -> + Sem effs a +runMockChainSubmitNode = interpret $ \case + SubmitTransaction cardanoTx -> do + -- We retrieve the local node connection info. + conn <- ask + -- 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 + 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/MockChain/Effect/Validation.hs b/src/Cooked/MockChain/Effect/Validation.hs index e552cd827..131aeb8e4 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/MockChain/Effect/Validation.hs @@ -8,35 +8,30 @@ module Cooked.MockChain.Effect.Validation ( -- * The `MockChainValidate` effect MockChainValidate (..), - runMockChainValidateEmul, - runMockChainValidateNode, - - -- * Sending `Cooked.Skeleton.TxSkel`s for validation - submitTransaction, validateTxSkel, validateTxSkel', validateTxSkelL, validateTxSkel_, + + -- * Interpreting the effect + runMockChainValidate, ) 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 import Cooked.MockChain.Common import Cooked.MockChain.Effect.Log import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Effect.Read.Conf +import Cooked.MockChain.Effect.Submission import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Cooked.Skeleton +import Data.Foldable.Extra 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 @@ -45,194 +40,127 @@ import PlutusLedgerApi.V3 qualified as Api import Polysemy import Polysemy.Error import Polysemy.Fail -import Polysemy.Reader import Polysemy.State --- | An effect that offers the ability to submit a transaction for validation, --- while returning the list of validation failures, if any. +-- | An effect that offers the ability to submit a 'TxSkel' throughout the +-- modification and validation pipeline. Technically, this effect is not needed +-- from a semantical perspective, as all of this could already be expressed in +-- 'MockChainSubmit', however, we want this effect to exist on its own to be +-- eligible to be modified by tweaks. data MockChainValidate :: Effect where - SubmitTransaction :: Tx -> MockChainValidate m [Conway.ConwayLedgerPredFailure Conway.ConwayEra] + ValidateTxSkel :: TxSkel -> MockChainValidate m (ExtendedTxSkel, SubmissionFailures, Transaction, Utxos) makeSem_ ''MockChainValidate -submitTransaction :: (Member MockChainValidate effs) => Tx -> Sem effs [Conway.ConwayLedgerPredFailure Conway.ConwayEra] - --- | Generates, balances and validates a transaction from a skeleton +-- | Generates, balances and validates a transaction from a skeleton. Returns +-- the extended skeleton, generated transaction and the new produced outputs. validateTxSkel :: - ( Members - '[ MockChainValidate, - MockChainLog, - MockChainReadChain, - MockChainReadConf, - Error P.Ledger.ToCardanoError, - Error MockChainError, - Fail - ] - effs - ) => + (Member MockChainValidate 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) + Sem effs (ExtendedTxSkel, SubmissionFailures, Transaction, Utxos) -- | Same as `validateTxSkel`, but only returns the generated UTxOs validateTxSkel' :: - ( Members - '[ MockChainValidate, - MockChainLog, - MockChainReadChain, - MockChainReadConf, - Error P.Ledger.ToCardanoError, - Error MockChainError, - Fail - ] - effs - ) => + (Member MockChainValidate effs) => TxSkel -> Sem effs Utxos -validateTxSkel' = fmap snd . validateTxSkel +validateTxSkel' = fmap (view _4) . validateTxSkel --- | Same as `validateTxSkel`, but only returns the list of 'Api.TxOutRef' +-- | Same as `validateTxSkel'`, but only returns the list of produced +-- 'Api.TxOutRef' validateTxSkelL :: - ( Members - '[ MockChainValidate, - MockChainLog, - MockChainReadChain, - MockChainReadConf, - Error P.Ledger.ToCardanoError, - Error MockChainError, - Fail - ] - effs - ) => + (Member MockChainValidate effs) => TxSkel -> Sem effs [Api.TxOutRef] -validateTxSkelL = fmap (Set.toList . Map.keysSet . snd) . validateTxSkel +validateTxSkelL = fmap (toList . Map.keysSet) . validateTxSkel' -- | Same as `validateTxSkel`, but discards the returned transaction validateTxSkel_ :: - ( Members - '[ MockChainValidate, - MockChainLog, - MockChainReadChain, - MockChainReadConf, - Error P.Ledger.ToCardanoError, - Error MockChainError, - Fail - ] - effs - ) => + (Member MockChainValidate 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 - SubmitTransaction cardanoTx -> do - -- To run transaction validation we need a minimal ledger state - eLedgerState <- gets emulatorStateLedgerState - -- And the emulator params - params <- gets emulatorStateParams - -- 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`). -runMockChainValidateNode :: - forall effs a. +-- | Interpretes the 'MockChainValidate' effects in terms of other effects, in +-- particular 'MockChainSubmit'. +runMockChainValidate :: ( Members - '[ Embed IO, - Error Cardano.EraMismatch, + '[ MockChainLog, + MockChainReadChain, MockChainReadConf, - Reader Cardano.LocalNodeConnectInfo, + MockChainSubmit, + Error P.Ledger.ToCardanoError, + Error MockChainError, + State ChainIndex, Fail ] effs ) => Sem (MockChainValidate : effs) a -> Sem effs a -runMockChainValidateNode = interpret $ \case - SubmitTransaction cardanoTx -> do - -- We retrieve the local node connection info. - conn <- ask - -- 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 - 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 [] +runMockChainValidate = interpret $ \case + 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 + eSkel@(ExtendedTxSkel finalTxSkel fee mCollaterals txBody exUnitsFailures) <- runAutomationPipeline txSkel + -- We log the adjusted skeleton + logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals + -- We handle the execution units failures when applicable + when (notNull exUnitsFailures) $ + if txSkelOptHaltOnExUnitsFailures + -- If requested, we treat them as fatal, ending the run + then throw $ MCEExUnitsFailures exUnitsFailures + -- Otherwise, we just log them + else logEvent $ MCELogExUnitsFailures exUnitsFailures + -- We build the Cardano transaction, and apply on it the modification in the + -- skeleton option + let cardanoTx = txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx (view txSkelSignatoriesL finalTxSkel) txBody + -- We wrap it for plutus-ledger usage + let pCardanoTx = P.Ledger.CardanoTx cardanoTx Cardano.ShelleyBasedEraConway + -- We compute the id of the new transaction + let txId = P.Ledger.fromCardanoTxId $ P.Ledger.getCardanoTxId pCardanoTx + -- We submit the transaction for validation + submissionFailures <- submitTransaction cardanoTx + -- We handle the submission failures when applicable + when (notNull submissionFailures) $ + if txSkelOptHaltOnSubmissionFailures + -- If requested, we treat them as fatal, ending the run + then throw $ MCESubmissionFailures submissionFailures + -- Otherwise, we just log them + else logEvent $ MCELogSubmissionFailures submissionFailures + -- We compute the set of consumed outputs and new outputs, based on the + -- validity of the transaction, producing some validity logs in the process. + (consumedInputs, newOutputs) <- + if + -- the transaction is valid, the index is modified based on the regular + -- inputs and outputs of the transaction. + | null submissionFailures && null exUnitsFailures -> do + let inputs = Map.keysSet $ txSkelInputs finalTxSkel + outputs = fromCardanoIndex (P.Ledger.getCardanoTxProducedOutputs pCardanoTx) $ txSkelOutputs finalTxSkel + logEvent $ MCLogNewTx txId $ Valid (length inputs) (Map.size outputs) + return (inputs, outputs) + -- the transaction fails in phase 1, the index remains unchanged. + | notNull submissionFailures -> do + logEvent $ MCLogNewTx txId InvalidPhase1 + return (Set.empty, Map.empty) + -- the transaction fails in phase 2, but no collaterals were + -- provided. This is an unreachable case. + | Nothing <- mCollaterals -> + fail + "Unreachable case when processing validation result, please report a bug at https://github.com/tweag/cooked-validators/issues" + -- the transaction fails in phase 2, and collaterals are provided, the + -- index is modified based on the collateral inputs and outputs of the + -- transaction. + | Just (colIns, retCol) <- mCollaterals -> do + let outputs = fromCardanoIndex (P.Ledger.getCardanoTxProducedReturnCollateral pCardanoTx) $ toList retCol + logEvent $ MCLogNewTx txId $ InvalidPhase2 (length colIns) (Map.size outputs) + return (colIns, outputs) + -- We update the index with the consumed and produced outputs + modify' $ removeOutputs consumedInputs + modify' $ addOutputs $ Map.toList newOutputs + return (eSkel, submissionFailures, cardanoTx, newOutputs) + where + fromCardanoIndex index = Map.fromList . zip (P.Ledger.fromCardanoTxIn . fst <$> Map.toList index) diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index 6c57638b3..9390c73c8 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.Submission import Cooked.MockChain.Effect.Validation import Cooked.MockChain.Effect.Write import Cooked.MockChain.Run.Runnable @@ -95,7 +96,11 @@ instance RunnableMockChain DirectEffs where . runMockChainReadConfEmul . runMockChainReadChainEmul . runMockChainWrite - . runMockChainValidateEmul + . runMockChainSubmitEmul + . runMockChainValidate + . insertAt @1 + @'[ MockChainSubmit + ] . insertAt @6 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, @@ -167,7 +172,11 @@ instance RunnableMockChain FullEffs where . evalState [] . runModifyLocally . runMockChainWrite - . runMockChainValidateEmul + . runMockChainSubmitEmul + . runMockChainValidate + . insertAt @1 + @'[ MockChainSubmit + ] . reinterpretMockChainValidateWithTweak @FullTweakEffs . runModifyGlobally @@ -224,7 +233,11 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . evalState [] . runModifyLocally . runMockChainWrite - . runMockChainValidateEmul + . runMockChainSubmitEmul + . runMockChainValidate + . insertAt @1 + @'[ MockChainSubmit + ] . insertAt @9 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/MockChain/Runtime/Error.hs index 032ec159f..30775baff 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/MockChain/Runtime/Error.hs @@ -10,8 +10,8 @@ module Cooked.MockChain.Runtime.Error ) where +import Cooked.MockChain.Common import Cooked.Skeleton.User -import Ledger.Index qualified as P.Ledger import Ledger.Slot qualified as P.Ledger import Ledger.Tx qualified as P.Ledger import PlutusLedgerApi.V3 qualified as Api @@ -40,8 +40,10 @@ 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] + = -- | Failures occurring while computing execution units + MCEExUnitsFailures ExUnitsFailures + | -- | Failures occurring while submitting the transaction for validation + MCESubmissionFailures SubmissionFailures | -- | Balancing errors MCEBalancingError BalancingError | -- | Translating a skeleton element to its Cardano counterpart failed diff --git a/src/Cooked/MockChain/Runtime/State.hs b/src/Cooked/MockChain/Runtime/State.hs index acc3bee03..55abdad60 100644 --- a/src/Cooked/MockChain/Runtime/State.hs +++ b/src/Cooked/MockChain/Runtime/State.hs @@ -36,6 +36,7 @@ module Cooked.MockChain.Runtime.State addOutput, addOutputs, removeOutput, + removeOutputs, -- * `UtxoState`: A simplified, address-focused view on a `ChainIndex` UtxoPayloadDatum (..), @@ -140,6 +141,10 @@ addOutputs outputs chainIndex = removeOutput :: Api.TxOutRef -> ChainIndex -> ChainIndex removeOutput oRef = set (chainIndexOutputsL % at oRef % _Just % _2) False +-- | Removes several outputs from a 'ChainIndex' using 'removeOutput' each time +removeOutputs :: (Foldable t) => t Api.TxOutRef -> ChainIndex -> ChainIndex +removeOutputs l index = foldl (flip removeOutput) index l + -- | A simplified version of a 'Cooked.Skeleton.Datum.TxSkelOutDatum' which only -- stores the actual datum and whether it is hashed (@True@) or inline -- (@False@). The only difference is that whether the datum was resolved in the diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index 86c3a8e3d..b591b87bf 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -85,6 +85,7 @@ module Cooked.MockChain.Testing ) where +import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Exception qualified as E import Control.Monad import Cooked.MockChain.Effect.Log @@ -96,11 +97,10 @@ import Cooked.MockChain.Runtime.State import Cooked.Pretty import Data.Default import Data.List (isInfixOf) +import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as T -import Ledger.Index qualified as P.Ledger import Plutus.Script.Utils.Address qualified as Script -import PlutusLedgerApi.V1.Scripts qualified as Api import PlutusLedgerApi.V1.Value qualified as Api import Polysemy import Test.QuickCheck qualified as QC @@ -559,11 +559,20 @@ withErrorProp test errorProp = withFailureProp test (\_ _ err _ -> errorProp err -- * Specific properties around failures +-- | Whether a script failure is a genuine Plutus (phase 2) evaluation failure. +-- Only the 'Alonzo.ValidationFailure' constructor is considered a phase 2 +-- failure; every other constructor is treated as a phase 1 failure. +isValidationFailure :: Alonzo.TransactionScriptFailure era -> Bool +isValidationFailure Alonzo.ValidationFailure {} = True +isValidationFailure _ = False + -- | A property to ensure a phase 1 failure isPhase1Failure :: (IsProp prop) => FailureProp prop -isPhase1Failure _ _ (MCEValidationError P.Ledger.Phase1 _) _ = testSuccess +isPhase1Failure _ _ (MCESubmissionFailures _) _ = testSuccess +isPhase1Failure _ _ (MCEExUnitsFailures failures) _ + | not (any isValidationFailure (Map.elems failures)) = testSuccess isPhase1Failure pcOpts _ e _ = testFailureMsg $ "Expected phase 1 evaluation failure, got: " @@ -573,7 +582,8 @@ isPhase1Failure pcOpts _ e _ = isPhase2Failure :: (IsProp prop) => FailureProp prop -isPhase2Failure _ _ (MCEValidationError P.Ledger.Phase2 _) _ = testSuccess +isPhase2Failure _ _ (MCEExUnitsFailures failures) _ + | any isValidationFailure (Map.elems failures) = testSuccess isPhase2Failure pcOpts _ e _ = testFailureMsg $ "Expected phase 2 evaluation failure, got: " @@ -584,8 +594,10 @@ isPhase1FailureWithMsg :: (IsProp prop) => String -> FailureProp prop -isPhase1FailureWithMsg s _ _ (MCEValidationError P.Ledger.Phase1 l) _ - | not $ null [text | P.Ledger.CardanoLedgerValidationError (T.unpack -> text) <- l, s `isInfixOf` text] = testSuccess +isPhase1FailureWithMsg s _ _ (MCESubmissionFailures failures) _ + | any (isInfixOf s . show) failures = testSuccess +isPhase1FailureWithMsg s _ _ (MCEExUnitsFailures failures) _ + | any (\f -> not (isValidationFailure f) && s `isInfixOf` show f) (Map.elems failures) = testSuccess isPhase1FailureWithMsg _ pcOpts _ e _ = testFailureMsg $ "Expected phase 1 evaluation failure with constrained messages, got: " @@ -596,8 +608,8 @@ isPhase2FailureWithMsg :: (IsProp prop) => String -> FailureProp prop -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 s _ _ (MCEExUnitsFailures failures) _ + | not $ null [text | Alonzo.ValidationFailure _ _ logs _ <- Map.elems failures, (T.unpack -> text) <- logs, 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 597b30878..fa40685e4 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -86,8 +86,10 @@ instance PrettyCooked BalancingError where ] instance PrettyCooked MockChainError where - prettyCookedOpt opts (MCEValidationError plutusPhase plutusErrors) = - prettyItemize opts ("Validation errors (" <+> prettyCookedOpt opts plutusPhase <+> ")") "-" plutusErrors + prettyCookedOpt opts (MCEExUnitsFailures failures) = + prettyItemize opts "Execution units failures:" "-" (PP.viaShow <$> Map.elems failures :: [DocCooked]) + prettyCookedOpt opts (MCESubmissionFailures failures) = + prettyItemize opts "Submission failures:" "-" (PP.viaShow <$> failures :: [DocCooked]) prettyCookedOpt opts (MCEBalancingError err) = prettyCookedOpt opts err prettyCookedOpt _ (MCEToCardanoError cardanoError) = "Transaction generation error:" <+> PP.pretty cardanoError @@ -156,14 +158,30 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where mCollaterals ) ) - prettyCookedOpt opts (Contextualized _ (MCLogNewTx txId nb)) = + prettyCookedOpt opts (Contextualized _ (MCLogNewTx txId validity)) = prettyItemize opts - "New transaction successfully validated:" + "New transaction produced:" "-" - [ "Transaction id:" <+> prettyHash opts txId, - "Number of new outputs:" <+> PP.pretty nb - ] + ( ("Transaction id:" <+> prettyHash opts txId) + : case validity of + Valid nbInputs nbOutputs -> + [ "Validity: valid", + "Number of consumed inputs:" <+> PP.pretty nbInputs, + "Number of new outputs:" <+> PP.pretty nbOutputs + ] + InvalidPhase1 -> + ["Validity: invalid in phase 1 (no ledger change)"] + InvalidPhase2 nbColInputs nbRetColOutputs -> + [ "Validity: invalid in phase 2", + "Number of consumed collateral inputs:" <+> PP.pretty nbColInputs, + "Number of return collateral outputs:" <+> PP.pretty nbRetColOutputs + ] + ) + prettyCookedOpt opts (Contextualized _ (MCELogExUnitsFailures failures)) = + prettyItemize opts "Warning: execution units failures:" "-" (PP.viaShow <$> Map.elems failures :: [DocCooked]) + prettyCookedOpt opts (Contextualized _ (MCELogSubmissionFailures failures)) = + prettyItemize opts "Warning: submission failures:" "-" (PP.viaShow <$> failures :: [DocCooked]) prettyCookedOpt opts (Contextualized _ (MCLogDiscardedUtxos n s)) = prettyItemize @[DocCooked] opts diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index 68edf6ad9..cfd961a0b 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/src/Cooked/Pretty/Skeleton.hs @@ -5,11 +5,9 @@ module Cooked.Pretty.Skeleton (Contextualized (..)) where import Cooked.Pretty.Class -import Cooked.Pretty.Options import Cooked.Pretty.Plutus () import Cooked.Skeleton import Cooked.Wallet (Wallet) -import Data.Default import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes) @@ -281,10 +279,10 @@ instance PrettyCookedMaybe TxSkelOutDatum where 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. +-- | Pretty-print a list of transaction skeleton options, printing every option +-- (except the opaque transaction modification). instance PrettyCookedList TxSkelOpts where - prettyCookedOptListMaybe + prettyCookedOptList opts ( TxSkelOpts _ @@ -293,22 +291,26 @@ instance PrettyCookedList TxSkelOpts where txSkelOptBalanceOutputPolicy txSkelOptBalancingUtxos txSkelOptCollateralUtxos - txSkelOptDeferFailures txSkelOptMaxNbOfBalancingUtxos + txSkelOptHaltOnExUnitsFailures + txSkelOptHaltOnSubmissionFailures ) = - [ prettyIfNot def prettyBalanceOutputPolicy txSkelOptBalanceOutputPolicy, - prettyIfNot def prettyBalanceFeePolicy txSkelOptFeePolicy, - prettyIfNot def prettyBalancingPolicy txSkelOptBalancingPolicy, - prettyIfNot def prettyBalancingUtxos txSkelOptBalancingUtxos, - prettyIfNot def prettyCollateralUtxos txSkelOptCollateralUtxos, - prettyIfNot False (const "Defer Phase 2 failures during balancing") txSkelOptDeferFailures, - ("Limit the number of balancing Utxos to " <>) . PP.pretty <$> txSkelOptMaxNbOfBalancingUtxos + [ prettyBalanceOutputPolicy txSkelOptBalanceOutputPolicy, + prettyBalanceFeePolicy txSkelOptFeePolicy, + prettyBalancingPolicy txSkelOptBalancingPolicy, + prettyBalancingUtxos txSkelOptBalancingUtxos, + prettyCollateralUtxos txSkelOptCollateralUtxos, + prettyMaxNbOfBalancingUtxos txSkelOptMaxNbOfBalancingUtxos, + prettyHaltOnFailures "computing execution units" txSkelOptHaltOnExUnitsFailures, + prettyHaltOnFailures "submission" txSkelOptHaltOnSubmissionFailures ] where - prettyIfNot :: (Eq a) => a -> (a -> DocCooked) -> a -> Maybe DocCooked - prettyIfNot defaultValue f x - | x == defaultValue && not (pcOptPrintDefaultTxSkelOpts opts) = Nothing - | otherwise = Just $ f x + prettyMaxNbOfBalancingUtxos :: Maybe Integer -> DocCooked + prettyMaxNbOfBalancingUtxos Nothing = "No limit on the number of balancing Utxos" + prettyMaxNbOfBalancingUtxos (Just n) = "Limit the number of balancing Utxos to " <> PP.pretty n + prettyHaltOnFailures :: DocCooked -> Bool -> DocCooked + prettyHaltOnFailures step False = "Proceed after failures while" <+> step + prettyHaltOnFailures step True = "Halt after failures while" <+> step 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.hs b/src/Cooked/Skeleton.hs index 9f58e1b96..17dde5520 100644 --- a/src/Cooked/Skeleton.hs +++ b/src/Cooked/Skeleton.hs @@ -43,6 +43,8 @@ module Cooked.Skeleton -- * Smart constructor txSkelTemplate, + txSkelEmulatorTemplate, + txSkelNodeTemplate, -- * Utilities txSkelKnownTxOutRefs, @@ -66,7 +68,6 @@ import Cooked.Skeleton.User as X import Cooked.Skeleton.ValidityRange as X import Cooked.Skeleton.Value as X import Cooked.Skeleton.Withdrawal as X -import Data.Default import Data.Map (Map) import Data.Map qualified as Map import Data.Set (Set) @@ -241,12 +242,13 @@ txSkelRedeemersT = txSkelSpendingRedeemersT `adjoin` (txSkelRedeemedScriptsT % userRedeemerL) --- | A convenience template of an empty transaction skeleton. -txSkelTemplate :: TxSkel -txSkelTemplate = +-- | A convenience template of an empty transaction skeleton, parameterized by +-- the transaction options to use. +txSkelTemplate :: TxSkelOpts -> TxSkel +txSkelTemplate opts = TxSkel { txSkelLabels = mempty, - txSkelOpts = def, + txSkelOpts = opts, txSkelMints = mempty, txSkelValidityRange = Api.always, txSkelSignatories = mempty, @@ -258,6 +260,16 @@ txSkelTemplate = txSkelCertificates = mempty } +-- | A convenience template of an empty transaction skeleton, using options +-- tailored for the emulator backend ('txSkelOptsEmulatorTemplate'). +txSkelEmulatorTemplate :: TxSkel +txSkelEmulatorTemplate = txSkelTemplate txSkelOptsEmulatorTemplate + +-- | A convenience template of an empty transaction skeleton, using options +-- tailored for a deployed node backend ('txSkelOptsNodeTemplate'). +txSkelNodeTemplate :: TxSkel +txSkelNodeTemplate = txSkelTemplate txSkelOptsNodeTemplate + -- | All 'Api.TxOutRef's in reference inputs from redeemers txSkelReferenceInputsInRedeemers :: TxSkel -> Set Api.TxOutRef txSkelReferenceInputsInRedeemers = diff --git a/src/Cooked/Skeleton/Option.hs b/src/Cooked/Skeleton/Option.hs index fa936a036..bf956370a 100644 --- a/src/Cooked/Skeleton/Option.hs +++ b/src/Cooked/Skeleton/Option.hs @@ -18,15 +18,18 @@ module Cooked.Skeleton.Option txSkelOptFeePolicyL, txSkelOptBalancingUtxosL, txSkelOptCollateralUtxosL, - txSkelOptOptimizeFeeInCaseOfScriptFailuresL, txSkelOptMaxNbOfBalancingUtxosL, + txSkelOptHaltOnExUnitsFailuresL, + txSkelOptHaltOnSubmissionFailuresL, -- * Utilities txSkelOptAddModTx, + txSkelOptsEmulatorTemplate, + txSkelOptsNodeTemplate, ) where -import Cardano.Api qualified as Cardano +import Cooked.MockChain.Common import Data.Default import Data.Set (Set) import Data.Typeable @@ -144,7 +147,7 @@ data TxSkelOpts = TxSkelOpts -- > txSkelOptModTx = Debug.Trace.traceShowId -- -- Default is @id@. - txSkelOptModTx :: Cardano.Tx Cardano.ConwayEra -> Cardano.Tx Cardano.ConwayEra, + txSkelOptModTx :: Transaction -> Transaction, -- | Whether to balance the transaction or not, and which user should -- provide/reclaim the missing and surplus value. -- @@ -172,24 +175,6 @@ data TxSkelOpts = TxSkelOpts -- -- Default is 'CollateralUtxosFromBalancingUser' txSkelOptCollateralUtxos :: CollateralUtxos, - -- | Whether to defer validation failures occurring during balancing - -- (specifically during the computation of execution units) to the actual - -- later submission of the transaction. - -- - -- When set to @False@: the phase 2 validation failures will be caught as - -- 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 an optimial balanced version of the failing - -- `Cooked.Skeleton.TxSkel`, which would not be computed otherwise. - -- - -- Default is `False` - 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 @@ -203,27 +188,40 @@ data TxSkelOpts = TxSkelOpts -- added in the inputs of the transaction, if such a Utxo exist. -- -- Default is @Nothing@ - txSkelOptMaxNbOfBalancingUtxos :: Maybe Integer + txSkelOptMaxNbOfBalancingUtxos :: Maybe Integer, + -- | Whether to halt the mockchain run when a failure occurs while computing + -- execution units during balancing (typically a phase 2 script failure + -- uncovered early). When 'False', such failures are only logged. + -- + -- Default is 'True' + txSkelOptHaltOnExUnitsFailures :: Bool, + -- | Whether to halt the mockchain run when a failure occurs while submitting + -- the transaction for validation. When 'False', such failures are only + -- logged. + -- + -- Default is 'True' + txSkelOptHaltOnSubmissionFailures :: Bool } -- | Comparing 'TxSkelOpts' is possible as long as we ignore modifications to the -- generated transaction and the parameters. instance Eq TxSkelOpts where - (TxSkelOpts _ balancingPol feePol balOutputPol balUtxos colUtxos deferFailures maxNbBalUtxos) - == (TxSkelOpts _ balancingPol' feePol' balOutputPol' balUtxos' colUtxos' deferFailures' maxNbBalUtxos') = + (TxSkelOpts _ balancingPol feePol balOutputPol balUtxos colUtxos maxNbBalUtxos exUnitsPol subPol) + == (TxSkelOpts _ balancingPol' feePol' balOutputPol' balUtxos' colUtxos' maxNbBalUtxos' exUnitsPol' subPol') = balancingPol == balancingPol' && feePol == feePol' && balOutputPol == balOutputPol' && balUtxos == balUtxos' && colUtxos == colUtxos' - && deferFailures == deferFailures' && maxNbBalUtxos == maxNbBalUtxos' + && exUnitsPol == exUnitsPol' + && subPol == subPol' -- | Showing 'TxSkelOpts' is possible as long as we ignore modifications to the -- generated transaction and the parameters. instance Show TxSkelOpts where - show (TxSkelOpts _ balancingPol feePol balOutputPol balUtxos colUtxos deferFailures maxNbBalUtxos) = - show [show balancingPol, show feePol, show balOutputPol, show balUtxos, show colUtxos, show deferFailures, show maxNbBalUtxos] + show (TxSkelOpts _ balancingPol feePol balOutputPol balUtxos colUtxos maxNbBalUtxos exUnitsPol subPol) = + show [show balancingPol, show feePol, show balOutputPol, show balUtxos, show colUtxos, show maxNbBalUtxos, show exUnitsPol, show subPol] -- | Focuses on the Cardano transaction modifications option of a 'TxSkelOpts' makeLensesFor [("txSkelOptModTx", "txSkelOptModTxL")] ''TxSkelOpts @@ -243,25 +241,54 @@ makeLensesFor [("txSkelOptBalancingUtxos", "txSkelOptBalancingUtxosL")] ''TxSkel -- | Focuses on the collateral utxos option of a 'TxSkelOpts' makeLensesFor [("txSkelOptCollateralUtxos", "txSkelOptCollateralUtxosL")] ''TxSkelOpts --- | Focuses on the deferring of the failures option of a 'TxSkelOpts' -makeLensesFor [("txSkelOptOptimizeFeeInCaseOfScriptFailures", "txSkelOptOptimizeFeeInCaseOfScriptFailuresL")] ''TxSkelOpts - -- | Focuses on the max nb of balancing Utxos option of a 'TxSkelOpts' makeLensesFor [("txSkelOptMaxNbOfBalancingUtxos", "txSkelOptMaxNbOfBalancingUtxosL")] ''TxSkelOpts -instance Default TxSkelOpts where - def = - TxSkelOpts - { txSkelOptModTx = id, - txSkelOptBalancingPolicy = def, - txSkelOptBalanceOutputPolicy = def, - txSkelOptFeePolicy = def, - txSkelOptBalancingUtxos = def, - txSkelOptCollateralUtxos = def, - txSkelOptOptimizeFeeInCaseOfScriptFailures = False, - txSkelOptMaxNbOfBalancingUtxos = Nothing - } +-- | Focuses on the halt-on-execution-units-failures option of a 'TxSkelOpts' +makeLensesFor [("txSkelOptHaltOnExUnitsFailures", "txSkelOptHaltOnExUnitsFailuresL")] ''TxSkelOpts + +-- | Focuses on the halt-on-submission-failures option of a 'TxSkelOpts' +makeLensesFor [("txSkelOptHaltOnSubmissionFailures", "txSkelOptHaltOnSubmissionFailuresL")] ''TxSkelOpts -- | Appends a transaction modification to the given 'TxSkelOpts' -txSkelOptAddModTx :: (Cardano.Tx Cardano.ConwayEra -> Cardano.Tx Cardano.ConwayEra) -> TxSkelOpts -> TxSkelOpts +txSkelOptAddModTx :: (Transaction -> Transaction) -> TxSkelOpts -> TxSkelOpts txSkelOptAddModTx modTx = over txSkelOptModTxL (modTx .) + +-- | A sensible set of options when running against the emulator backend. The +-- emulator is local and deterministic and reports complete failures, so we opt +-- to halt on both execution-units and submission failures to surface problems +-- as early and as loudly as possible. Balancing is kept unbounded since the +-- emulator typically deals with only a handful of Utxos. +txSkelOptsEmulatorTemplate :: TxSkelOpts +txSkelOptsEmulatorTemplate = + TxSkelOpts + { txSkelOptModTx = id, + txSkelOptBalancingPolicy = def, + txSkelOptBalanceOutputPolicy = def, + txSkelOptFeePolicy = def, + txSkelOptBalancingUtxos = def, + txSkelOptCollateralUtxos = def, + txSkelOptMaxNbOfBalancingUtxos = Nothing, + txSkelOptHaltOnExUnitsFailures = True, + txSkelOptHaltOnSubmissionFailures = True + } + +-- | A sensible set of options when running against a deployed node backend. A +-- real node may reject transactions for reasons outside of the caller's +-- control, so we do not halt after execution-units and submission failures, +-- letting the mockchain run continue and surface issues through the log rather +-- than aborting. Balancing is capped to keep Utxo selection tractable when the +-- node exposes many candidate Utxos. +txSkelOptsNodeTemplate :: TxSkelOpts +txSkelOptsNodeTemplate = + TxSkelOpts + { txSkelOptModTx = id, + txSkelOptBalancingPolicy = def, + txSkelOptBalanceOutputPolicy = def, + txSkelOptFeePolicy = def, + txSkelOptBalancingUtxos = def, + txSkelOptCollateralUtxos = def, + txSkelOptMaxNbOfBalancingUtxos = Just 10, + txSkelOptHaltOnExUnitsFailures = False, + txSkelOptHaltOnSubmissionFailures = False + } diff --git a/src/Cooked/Tweak/Guard.hs b/src/Cooked/Tweak/Guard.hs index 8d3e70eca..5cd73df4f 100644 --- a/src/Cooked/Tweak/Guard.hs +++ b/src/Cooked/Tweak/Guard.hs @@ -61,7 +61,7 @@ condTweak optic = (guardTweak optic >>) -- > -- > someEndpoint = do -- > ... --- > validateTxSkel' txSkelTemplate +-- > validateTxSkel' txSkelEmulatorTemplate -- > { txSkelLabels = -- > [ TxSkelLabel "InitialMinting" -- > , TxSkelLabel "AuctionWorkflow" @@ -84,7 +84,7 @@ labelled lbl = condTweak $ txSkelLabelsL % at (TxSkelLabel lbl) % _Just -- > -- > someEndpoint = do -- > ... --- > validateTxSkel' txSkelTemplate +-- > validateTxSkel' txSkelEmulatorTemplate -- > { txSkelLabels = -- > [ TxSkelLabel "InitialMinting" -- > , TxSkelLabel "AuctionWorkflow" diff --git a/tests/Spec/Attack/DatumHijacking.hs b/tests/Spec/Attack/DatumHijacking.hs index 9a6202a28..44eae99d4 100644 --- a/tests/Spec/Attack/DatumHijacking.hs +++ b/tests/Spec/Attack/DatumHijacking.hs @@ -23,7 +23,7 @@ instance PrettyCooked LockDatum where lockTxSkel :: Api.TxOutRef -> Script.MultiPurposeScript DHContract -> TxSkel lockTxSkel o v = - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton o emptyTxSkelRedeemer, txSkelOutputs = [v `receives` InlineDatum FirstLock <&&> Value lockValue], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -36,7 +36,7 @@ txLock v = do relockTxSkel :: Script.MultiPurposeScript DHContract -> Api.TxOutRef -> TxSkel relockTxSkel v o = - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton o $ someTxSkelRedeemer (), txSkelOutputs = [v `receives` InlineDatum SecondLock <&&> Value lockValue], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -66,7 +66,7 @@ tests = value_10_000 = Script.lovelace 10000 value_9_999 = Script.lovelace 9999 inSkel = - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [ carelessValidator `receives` InlineDatum SecondLock <&&> Value value_10_001, carelessValidator `receives` InlineDatum SecondLock <&&> Value value_9_999, diff --git a/tests/Spec/Attack/DatumTampering.hs b/tests/Spec/Attack/DatumTampering.hs index 8bd5d2dea..2ad99a7a2 100644 --- a/tests/Spec/Attack/DatumTampering.hs +++ b/tests/Spec/Attack/DatumTampering.hs @@ -17,7 +17,7 @@ alice = wallet 1 datumTamperingAttackTest :: TestTree datumTamperingAttackTest = testCase "datumTamperingAttack" $ - [ txSkelTemplate + [ txSkelEmulatorTemplate { txSkelLabels = Set.singleton $ TxSkelLabel $ DatumTamperingLabel [(52 :: Integer, 53 :: Integer)], txSkelOutputs = [ alice `receives` VisibleHashedDatum (52 :: Integer, 54 :: Integer), @@ -28,7 +28,7 @@ datumTamperingAttackTest = ] @=? (run . runNonDet) ( execTweak - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [ alice `receives` VisibleHashedDatum (52 :: Integer, 53 :: Integer), alice `receives` Value (Script.lovelace 234), @@ -62,7 +62,7 @@ malformDatumAttackTest = ] ( (fmap allBuiltinData . run . runNonDet) ( execTweak - ( txSkelTemplate + ( txSkelEmulatorTemplate { txSkelOutputs = [ alice `receives` VisibleHashedDatum (52 :: Integer, 53 :: Integer), alice `receives` Value (Script.lovelace 234), diff --git a/tests/Spec/Attack/OutputsReordering.hs b/tests/Spec/Attack/OutputsReordering.hs index a496accdf..33a2e413d 100644 --- a/tests/Spec/Attack/OutputsReordering.hs +++ b/tests/Spec/Attack/OutputsReordering.hs @@ -10,7 +10,7 @@ import Test.Tasty.HUnit manyOutputsSkeleton :: TxSkel manyOutputsSkeleton = - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = (\n -> wallet n `receives` Value (Script.ada 10)) <$> [1 .. 5] } diff --git a/tests/Spec/Attack/PeerTampering.hs b/tests/Spec/Attack/PeerTampering.hs index 294f094d5..d30b4a1cc 100644 --- a/tests/Spec/Attack/PeerTampering.hs +++ b/tests/Spec/Attack/PeerTampering.hs @@ -20,7 +20,7 @@ pkh = Script.toPubKeyHash . wallet -- exercises both branches of 'txSkelAllocatedPeersT'. baseSkel :: TxSkel baseSkel = - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [wallet 1 `receives` Value (Script.lovelace 3_000)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1, wallet 2] } diff --git a/tests/Spec/Attack/RedeemerTampering.hs b/tests/Spec/Attack/RedeemerTampering.hs index a1c5af889..39ab6b947 100644 --- a/tests/Spec/Attack/RedeemerTampering.hs +++ b/tests/Spec/Attack/RedeemerTampering.hs @@ -23,7 +23,7 @@ oref = Api.TxOutRef (Api.TxId "") -- must leave untouched. baseSkel :: TxSkel baseSkel = - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.fromList [ (oref 0, someTxSkelRedeemer (10 :: Integer)), @@ -41,7 +41,7 @@ integerRedeemers = toListOf (txSkelSpendingRedeemersT % txSkelRedeemerTypedAT) -- to make their redeemers invisible to the redeemer traversals. certificateSkel :: TxSkelRedeemer -> TxSkel certificateSkel red = - txSkelTemplate + txSkelEmulatorTemplate { txSkelCertificates = [TxSkelCertificate (UserRedeemedScript (toVScript $ Script.trueMPScript @()) red) StakingRegister] } diff --git a/tests/Spec/Attack/TokenDuplication.hs b/tests/Spec/Attack/TokenDuplication.hs index 8a0551993..e92ec731b 100644 --- a/tests/Spec/Attack/TokenDuplication.hs +++ b/tests/Spec/Attack/TokenDuplication.hs @@ -19,7 +19,7 @@ dupTokenTrace pol tName amount recipient = do skel = let mints = review txSkelMintsListI [mint pol () tName amount] mintedValue = Script.toValue mints - in txSkelTemplate + in txSkelEmulatorTemplate { txSkelMints = mints, txSkelOutputs = [recipient `receives` Value mintedValue], txSkelSignatories = txSkelSignatoriesFromList [wallet 3] @@ -38,7 +38,7 @@ tests = ac1 = Api.assetClass (Script.toCurrencySymbol pol1) tName1 ac2 = Api.assetClass (Script.toCurrencySymbol pol2) tName2 skelIn = - txSkelTemplate + txSkelEmulatorTemplate { txSkelMints = review txSkelMintsListI @@ -59,7 +59,7 @@ tests = [ (Script.toCurrencySymbol pol1, tName1, v1 - 5), (Script.toCurrencySymbol pol2, tName2, v2 - 7) ] - in [ ( txSkelTemplate + in [ ( txSkelEmulatorTemplate { txSkelLabels = Set.singleton $ TxSkelLabel $ TokenDuplicationLabel increment, txSkelMints = review @@ -103,13 +103,13 @@ tests = ac1 = Api.assetClass (Script.toCurrencySymbol pol) tName1 ac2 = Api.assetClass (Script.toCurrencySymbol Script.trueMintingMPScript) (Api.TokenName "preExistingToken") skelIn = - txSkelTemplate + txSkelEmulatorTemplate { txSkelMints = review txSkelMintsListI [mint pol () tName1 1], txSkelOutputs = [wallet 1 `receives` Value (Api.assetClassValue ac1 1 <> Api.assetClassValue ac2 2)], txSkelSignatories = txSkelSignatoriesFromList [wallet 2] } skelExpected = - [ ( txSkelTemplate + [ ( txSkelEmulatorTemplate { txSkelLabels = Set.singleton $ TxSkelLabel $ TokenDuplicationLabel $ review (valueAssetClassAmountP pol tName1) 1, txSkelMints = review txSkelMintsListI [mint pol () tName1 2], txSkelOutputs = diff --git a/tests/Spec/Attack/ValidityTampering.hs b/tests/Spec/Attack/ValidityTampering.hs index b7764529f..d5b44c338 100644 --- a/tests/Spec/Attack/ValidityTampering.hs +++ b/tests/Spec/Attack/ValidityTampering.hs @@ -31,7 +31,7 @@ runValidityTampering initialRange params = fmap (view txSkelValidityRangeL) . run . runNonDet - . execTweak (txSkelTemplate {txSkelValidityRange = initialRange}) + . execTweak (txSkelEmulatorTemplate {txSkelValidityRange = initialRange}) $ validityTamperingAttack params tests :: TestTree diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index 95e121674..3902c14e4 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -1,14 +1,12 @@ module Spec.Balancing where import Cooked -import Data.Default +import Data.List (isInfixOf) 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 import Optics.Core import Optics.Core.Extras import Plutus.Script.Utils.V3 qualified as Script @@ -69,7 +67,7 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla additionalSpend <- spendsScriptUtxo consumeScriptUtxo let valueConstr = if adjust then Value else FixedValue skel = - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = List.filter ((/= mempty) . (^. txSkelOutValueL)) @@ -79,7 +77,7 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla txSkelInputs = additionalSpend <> Map.fromSet (const emptyTxSkelRedeemer) toSpendUtxos, txSkelOpts = optionsMod - def + txSkelOptsEmulatorTemplate { txSkelOptBalancingUtxos = if List.null toBalanceUtxos then BalancingUtxosFromBalancingUser @@ -91,8 +89,7 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla }, txSkelSignatories = txSkelSignatoriesFromList [alice] } - ExtendedTxSkel skel' fee mCols _ <- balanceTxSkel skel - validateTxSkel_ skel + (ExtendedTxSkel skel' fee mCols _ _, _, _, _) <- validateTxSkel skel nonOnlyValueUtxos <- aliceNonOnlyValueUtxos return (skel, skel', fee, mCols, nonOnlyValueUtxos) @@ -142,11 +139,11 @@ noBalanceMaxFee = do maxFee <- snd <$> getMinAndMaxFee 0 aliceORefs30Ada <- aliceNAdaUtxos 30 validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [bob `receives` Value (Script.lovelace (30_000_000 - maxFee))], txSkelInputs = Map.fromSet (const emptyTxSkelRedeemer) aliceORefs30Ada, txSkelOpts = - def + txSkelOptsEmulatorTemplate { txSkelOptBalancingPolicy = DoNotBalance, txSkelOptFeePolicy = AutoFeeComputation }, @@ -156,32 +153,32 @@ noBalanceMaxFee = do balanceReduceFee :: FullMockChain (Integer, Integer, Integer, Integer) balanceReduceFee = do let skelAutoFee = - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [bob `receives` Value (Script.ada 50)], txSkelSignatories = txSkelSignatoriesFromList [alice] } - ExtendedTxSkel skelBalanced feeBalanced mCols _ <- balanceTxSkel skelAutoFee - (feeBalanced', _) <- estimateTxSkelFee skelBalanced feeBalanced mCols + ExtendedTxSkel skelBalanced feeBalanced mCols _ _ <- balanceTxSkel skelAutoFee + (feeBalanced', _, _) <- estimateTxSkelFee skelBalanced feeBalanced mCols let skelManualFee = skelAutoFee { txSkelOpts = - def + txSkelOptsEmulatorTemplate { txSkelOptFeePolicy = ManualFee (feeBalanced - 1) } } - ExtendedTxSkel skelBalancedManual feeBalancedManual mColsManual _ <- balanceTxSkel skelManualFee - (feeBalancedManual', _) <- estimateTxSkelFee skelBalancedManual feeBalancedManual mColsManual + ExtendedTxSkel skelBalancedManual feeBalancedManual mColsManual _ _ <- balanceTxSkel skelManualFee + (feeBalancedManual', _, _) <- estimateTxSkelFee skelBalancedManual feeBalancedManual mColsManual return (feeBalanced, feeBalanced', feeBalancedManual, feeBalancedManual') reachingMagic :: FullMockChain () reachingMagic = do bananaOutRefs <- getTxOutRefs $ utxosAtSearch alice $ ensureAFoldIs (txSkelOutValueL % filtered (banana 1 `Api.leq`)) validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [bob `receives` Value (Script.ada 106 <> banana 12)], txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelOpts = - def + txSkelOptsEmulatorTemplate { txSkelOptBalancingUtxos = BalancingUtxosFromSet bananaOutRefs } } @@ -221,15 +218,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 (MCESubmissionFailures failures) = testBool $ any (isInfixOf "FeeTooSmallUTxO" . show) failures failsWithTooLittleFee _ = testBool False failsWithValueNotConserved :: MockChainError -> Assertion -failsWithValueNotConserved (MCEValidationError P.Ledger.Phase1 [P.Ledger.CardanoLedgerValidationError text]) = testBool $ isInfixOf "ValueNotConserved" text +failsWithValueNotConserved (MCESubmissionFailures failures) = testBool $ any (isInfixOf "ValueNotConserved" . show) failures failsWithValueNotConserved _ = testBool False failsWithEmptyTxIns :: MockChainError -> Assertion -failsWithEmptyTxIns (MCEValidationError P.Ledger.Phase1 [P.Ledger.CardanoLedgerValidationError text]) = testBool $ isInfixOf "InputSetEmptyUTxO" text +failsWithEmptyTxIns (MCESubmissionFailures failures) = testBool $ any (isInfixOf "InputSetEmptyUTxO" . show) failures failsWithEmptyTxIns _ = testBool False failsAtCollateralsWith :: Integer -> MockChainError -> Assertion diff --git a/tests/Spec/BasicUsage.hs b/tests/Spec/BasicUsage.hs index 2c8a08e5d..ed7a6c0ff 100644 --- a/tests/Spec/BasicUsage.hs +++ b/tests/Spec/BasicUsage.hs @@ -15,7 +15,7 @@ carrie = wallet 3 pkToPk :: Wallet -> Wallet -> Integer -> StagedMockChain () pkToPk sender recipient amount = validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [recipient `receives` Value (Script.ada amount)], txSkelSignatories = txSkelSignatoriesFromList [sender] } @@ -30,7 +30,7 @@ multiplePksToPks = mintingQuickValue :: StagedMockChain () mintingQuickValue = validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelMints = review txSkelMintsListI [mint (Script.trueMintingMPScript @()) () (Api.TokenName "banana") 10], txSkelOutputs = [alice `receives` Value (Script.multiPurposeScriptValue (Script.trueMintingMPScript @()) (Api.TokenName "banana") 10)], txSkelSignatories = txSkelSignatoriesFromList [alice] @@ -40,7 +40,7 @@ payToAlwaysTrueValidator :: StagedMockChain Api.TxOutRef payToAlwaysTrueValidator = head <$> ( validateTxSkelL $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 10)], txSkelSignatories = txSkelSignatoriesFromList [alice] } @@ -50,7 +50,7 @@ consumeAlwaysTrueValidator :: StagedMockChain () consumeAlwaysTrueValidator = do outref <- payToAlwaysTrueValidator validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.fromList [(outref, someTxSkelRedeemer ())], txSkelOutputs = [alice `receives` Value (Script.ada 10)], txSkelSignatories = txSkelSignatoriesFromList [alice] diff --git a/tests/Spec/Certificates.hs b/tests/Spec/Certificates.hs index 29022d8b9..0ca602721 100644 --- a/tests/Spec/Certificates.hs +++ b/tests/Spec/Certificates.hs @@ -16,7 +16,7 @@ publishCertificate :: TxSkelCertificate -> DirectMockChain () publishCertificate cert = do forceOutputs_ [alice `receives` Value (Script.ada 100)] validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelCertificates = [cert] } @@ -24,7 +24,7 @@ publishCertificate cert = do withdraw :: User IsEither Redemption -> DirectMockChain () withdraw user = validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelWithdrawals = review txSkelWithdrawalsListI [Withdrawal user Nothing] } diff --git a/tests/Spec/InitialDistribution.hs b/tests/Spec/InitialDistribution.hs index 6fc815084..d74c5060b 100644 --- a/tests/Spec/InitialDistribution.hs +++ b/tests/Spec/InitialDistribution.hs @@ -32,12 +32,12 @@ spendReferenceAlwaysTrueValidator = do (fst . Map.elemAt 0 -> referenceScriptTxOutRef) <- utxosAt alice (scriptTxOutRef : _) <- validateTxSkelL $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [Script.trueSpendingMPScript @() `receives` Value (Script.ada 2)], txSkelSignatories = txSkelSignatoriesFromList [bob] } validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [alice `receives` Value (Script.ada 2)], txSkelInputs = Map.singleton scriptTxOutRef $ TxSkelRedeemer () (Just referenceScriptTxOutRef) False, txSkelSignatories = txSkelSignatoriesFromList [bob] diff --git a/tests/Spec/InlineDatums.hs b/tests/Spec/InlineDatums.hs index 24bcdcbe1..2227ba4b9 100644 --- a/tests/Spec/InlineDatums.hs +++ b/tests/Spec/InlineDatums.hs @@ -25,7 +25,7 @@ listUtxosTestTrace :: listUtxosTestTrace useInlineDatum validator = Map.elemAt 0 <$> validateTxSkel' - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [validator `receives` (if useInlineDatum then InlineDatum else VisibleHashedDatum) FirstPaymentDatum], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } @@ -44,7 +44,7 @@ spendOutputTestTrace :: spendOutputTestTrace useInlineDatum validator = do (theTxOutRef, _) <- listUtxosTestTrace useInlineDatum validator validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton theTxOutRef $ someTxSkelRedeemer (), txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } @@ -66,7 +66,7 @@ continuingOutputTestTrace :: continuingOutputTestTrace datumKindOnSecondPayment validator = do (theTxOutRef, theOutput) <- listUtxosTestTrace True validator validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton theTxOutRef $ someTxSkelRedeemer (), txSkelOutputs = [ validator diff --git a/tests/Spec/MinAda.hs b/tests/Spec/MinAda.hs index 6989b65eb..0c4346425 100644 --- a/tests/Spec/MinAda.hs +++ b/tests/Spec/MinAda.hs @@ -27,7 +27,7 @@ paymentWithMinAda = do forceOutputs_ initialDistributionTemplate view (txSkelOutValueL % valueLovelaceL % lovelaceIntegerI) . snd . Map.elemAt 0 <$> validateTxSkel' - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [wallet 2 `receives` VisibleHashedDatum heavyDatum], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } @@ -35,7 +35,7 @@ paymentWithMinAda = do paymentWithoutMinAda :: Integer -> DirectMockChain () paymentWithoutMinAda paidLovelaces = do validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [wallet 2 `receives` FixedValue (Script.lovelace paidLovelaces) <&&> VisibleHashedDatum heavyDatum], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } diff --git a/tests/Spec/MultiPurpose.hs b/tests/Spec/MultiPurpose.hs index 42cf92751..969c3aa0b 100644 --- a/tests/Spec/MultiPurpose.hs +++ b/tests/Spec/MultiPurpose.hs @@ -27,7 +27,7 @@ runScript = do forceOutputs_ initialDistributionTemplate [oRef@(Api.TxOutRef txId _), oRef', oRef''] <- validateTxSkelL $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [ alice `receives` Value (Script.ada 3), alice `receives` Value (Script.ada 5) @@ -46,7 +46,7 @@ runScript = do (oRefScript1' : oRefScript2' : _) <- validateTxSkelL $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelInputs = HMap.fromList @@ -63,7 +63,7 @@ runScript = do (oRefScript2'' : _) <- validateTxSkelL $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [bob], txSkelInputs = HMap.fromList @@ -77,7 +77,7 @@ runScript = do } validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelInputs = HMap.singleton oRefScript2'' (someTxSkelRedeemer Close), txSkelMints = review txSkelMintsListI [burn script BurnToken tn3 1] @@ -88,7 +88,7 @@ runScript = do let tn = txOutRefToToken oRef mints = review txSkelMintsListI [mint script (MintToken oRef) tn 1] mintValue = Script.toValue mints - in ( txSkelTemplate + in ( txSkelEmulatorTemplate { txSkelInputs = HMap.singleton oRef emptyTxSkelRedeemer, txSkelMints = mints, txSkelOutputs = [script `receives` InlineDatum index <&&> Value mintValue], diff --git a/tests/Spec/ProposingScript.hs b/tests/Spec/ProposingScript.hs index 842e659ea..c232fa595 100644 --- a/tests/Spec/ProposingScript.hs +++ b/tests/Spec/ProposingScript.hs @@ -24,17 +24,17 @@ testProposingScript autoRefScript autoConstitution constitution mScript govActio forceOutputs_ initialDistributionTemplate setConstitutionScript constitution validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [alice `receives` ReferenceScript constitution], txSkelSignatories = txSkelSignatoriesFromList [alice] } validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelCertificates = [pubKeyCertificate alice $ StakingRegisterDelegate (Api.DelegVote Api.DRepAlwaysAbstain)] } validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelProposals = [ TxSkelProposal diff --git a/tests/Spec/ReferenceInputs.hs b/tests/Spec/ReferenceInputs.hs index 234951169..c8111479d 100644 --- a/tests/Spec/ReferenceInputs.hs +++ b/tests/Spec/ReferenceInputs.hs @@ -17,7 +17,7 @@ trace1 :: DirectMockChain () trace1 = do txOutRefFoo : txOutRefBar : _ <- validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [ fooTypedValidator `receives` Value (Script.ada 4) <&&> InlineDatum (FooDatum $ Script.toPubKeyHash $ wallet 3), barTypedValidator `receives` Value (Script.ada 5) @@ -25,7 +25,7 @@ trace1 = do txSkelSignatories = txSkelSignatoriesFromList [wallet 2] } validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton txOutRefBar $ someTxSkelRedeemer (), txSkelReferenceInputs = Set.singleton txOutRefFoo, txSkelOutputs = [wallet 4 `receives` Value (Script.ada 5)], @@ -36,7 +36,7 @@ trace2 :: DirectMockChain () trace2 = do refORef : scriptORef : _ <- validateTxSkelL - ( txSkelTemplate + ( txSkelEmulatorTemplate { txSkelOutputs = [ wallet 1 `receives` Value (Script.ada 2) <&&> VisibleHashedDatum (10 :: Integer), bazTypedValidator `receives` Value (Script.ada 10) @@ -45,7 +45,7 @@ trace2 = do } ) validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [wallet 1], txSkelInputs = Map.singleton scriptORef (someTxSkelRedeemer ()), txSkelReferenceInputs = Set.singleton refORef diff --git a/tests/Spec/ReferenceScripts.hs b/tests/Spec/ReferenceScripts.hs index a5e6e6690..6cad7f154 100644 --- a/tests/Spec/ReferenceScripts.hs +++ b/tests/Spec/ReferenceScripts.hs @@ -20,7 +20,7 @@ putRefScriptOnWalletOutput :: putRefScriptOnWalletOutput recipient referenceScript = head <$> validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [recipient `receives` ReferenceScript referenceScript], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } @@ -32,7 +32,7 @@ putRefScriptOnScriptOutput :: putRefScriptOnScriptOutput recipient referenceScript = head <$> validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [recipient `receives` ReferenceScript referenceScript], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } @@ -44,12 +44,12 @@ checkReferenceScriptOnOref :: checkReferenceScriptOnOref expectedScriptHash refScriptOref = do oref : _ <- validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [requireRefScriptValidator expectedScriptHash `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton oref emptyTxSkelRedeemer, txSkelReferenceInputs = Set.singleton refScriptOref, txSkelSignatories = txSkelSignatoriesFromList [wallet 1] @@ -64,13 +64,13 @@ useReferenceScript spendingSubmitter consumeScriptOref theScript = do scriptOref <- putRefScriptOnWalletOutput (wallet 3) theScript oref : _ <- validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [theScript `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } - fst + (\(_, _, tx, _) -> P.Ledger.CardanoEmulatorEraTx tx) <$> validateTxSkel - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.fromList $ (oref, TxSkelRedeemer () (Just scriptOref) False) @@ -83,12 +83,12 @@ useReferenceScriptInInputs spendingSubmitter theScript = do scriptOref <- putRefScriptOnWalletOutput (wallet 1) theScript oref : _ <- validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [theScript `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.fromList [(oref, TxSkelRedeemer () (Just scriptOref) False), (scriptOref, emptyTxSkelRedeemer)], txSkelSignatories = txSkelSignatoriesFromList [spendingSubmitter] } @@ -97,7 +97,7 @@ referenceMint :: Script.Versioned Script.MintingPolicy -> Script.Versioned Scrip referenceMint mp1 mp2 n autoRefScript = do (Map.elemAt n -> (mpOutRef, _)) <- validateTxSkel' $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [ wallet 1 `receives` Value (Script.ada 2) <&&> ReferenceScript mp1, wallet 1 `receives` Value (Script.ada 10) @@ -105,7 +105,7 @@ referenceMint mp1 mp2 n autoRefScript = do txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelMints = review txSkelMintsListI @@ -154,13 +154,13 @@ tests = ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` Script.lovelace 42_000_000)) oref : _ <- validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], txSkelInputs = Map.singleton consumedOref emptyTxSkelRedeemer, txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton oref (TxSkelRedeemer () (Just consumedOref) False), txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } @@ -174,12 +174,12 @@ tests = scriptOref <- putRefScriptOnWalletOutput (wallet 3) Script.alwaysFailValidatorVersioned oref : _ <- validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton oref (TxSkelRedeemer () (Just scriptOref) False), txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } @@ -192,12 +192,12 @@ tests = scriptOref <- putRefScriptOnWalletOutput (wallet 3) Script.alwaysSucceedValidatorVersioned oref : _ <- validateTxSkelL - txSkelTemplate + txSkelEmulatorTemplate { txSkelOutputs = [Script.alwaysSucceedValidatorVersioned `receives` Value (Script.ada 42)], txSkelSignatories = txSkelSignatoriesFromList [wallet 1] } validateTxSkel_ - txSkelTemplate + txSkelEmulatorTemplate { txSkelInputs = Map.singleton oref emptyTxSkelRedeemerNoAutoFill, txSkelReferenceInputs = Set.singleton scriptOref, txSkelSignatories = txSkelSignatoriesFromList [wallet 1] diff --git a/tests/Spec/Tweak/Common.hs b/tests/Spec/Tweak/Common.hs index 49e96ccaa..afe3b491d 100644 --- a/tests/Spec/Tweak/Common.hs +++ b/tests/Spec/Tweak/Common.hs @@ -13,7 +13,7 @@ alice :: Wallet alice = wallet 1 mkSkel :: [Integer] -> TxSkel -mkSkel l = set txSkelOutputsL (receives alice . Value . Script.lovelace <$> l) txSkelTemplate +mkSkel l = set txSkelOutputsL (receives alice . Value . Script.lovelace <$> l) txSkelEmulatorTemplate tests :: TestTree tests = diff --git a/tests/Spec/Tweak/Labels.hs b/tests/Spec/Tweak/Labels.hs index 45b0bdaf7..ff5970795 100644 --- a/tests/Spec/Tweak/Labels.hs +++ b/tests/Spec/Tweak/Labels.hs @@ -17,7 +17,7 @@ carrie = wallet 3 payTo :: Wallet -> Integer -> StagedMockChain () payTo target amount = do validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelOutputs = [target `receives` Value (Script.ada amount)] } diff --git a/tests/Spec/Withdrawals.hs b/tests/Spec/Withdrawals.hs index 8ee6340e2..4c3d0ec8b 100644 --- a/tests/Spec/Withdrawals.hs +++ b/tests/Spec/Withdrawals.hs @@ -21,7 +21,7 @@ testWithdrawingScript userCertifying userRewarding mAmount = do forceOutputs_ [alice `receives` Value (Script.ada 100)] when (isJust userCertifying) $ validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelCertificates = [ TxSkelCertificate (fromJust userCertifying) $ @@ -31,7 +31,7 @@ testWithdrawingScript userCertifying userRewarding mAmount = do ] } validateTxSkel_ $ - txSkelTemplate + txSkelEmulatorTemplate { txSkelSignatories = txSkelSignatoriesFromList [alice], txSkelWithdrawals = txSkelWithdrawalsFromList [Withdrawal userRewarding (Api.Lovelace . (1_000_000 *) <$> mAmount)] } From abc80a7218667952439e85768a4ad760bfa7d10e Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 11 Aug 2026 16:30:10 +0200 Subject: [PATCH 20/39] TIME handling --- CHANGELOG.md | 8 + cooked-validators.cabal | 1 + src/Cooked/MockChain.hs | 1 + src/Cooked/MockChain/Effect/Read/Chain.hs | 117 +---------- src/Cooked/MockChain/Effect/Submission.hs | 5 +- src/Cooked/MockChain/Effect/Time.hs | 238 ++++++++++++++++++++++ src/Cooked/MockChain/Effect/Write.hs | 45 ---- src/Cooked/MockChain/Run/Instances.hs | 17 +- src/Cooked/MockChain/Runtime/Error.hs | 3 - src/Cooked/Pretty/MockChain.hs | 5 - tests/Spec/Slot.hs | 6 +- 11 files changed, 274 insertions(+), 172 deletions(-) create mode 100644 src/Cooked/MockChain/Effect/Time.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 990dc0295..46f7e88b5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,14 @@ ### Changed +- Time-related primitives have been regrouped into a new dedicated + `Cooked.MockChain.Effect.Time.MockChainTime` effect. The time queries + (`currentSlot`, `currentMSRange`, `getEnclosingSlot`, `slotToMSRange`, + `slotRangeBefore`, `slotRangeAfter`) that used to live in `MockChainReadChain` + and the waiting primitives (`waitNSlots`, `awaitSlot`, `awaitEnclosingSlot`, + `waitNMSFromSlotLowerBound`, `waitNMSFromSlotUpperBound`) that used to live in + `MockChainWrite` are now all provided by `MockChainTime`, with `waitNSlots` as + its sole state-modifying primitive. - 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) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index d76886b48..00f6b9649 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -48,6 +48,7 @@ library Cooked.MockChain.Effect.Read.Chain Cooked.MockChain.Effect.Read.Conf Cooked.MockChain.Effect.Submission + Cooked.MockChain.Effect.Time Cooked.MockChain.Effect.Validation Cooked.MockChain.Effect.Write Cooked.MockChain.Run.Instances diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index e5720a6c9..c413e3540 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.Time as X import Cooked.MockChain.Effect.Validation as X import Cooked.MockChain.Effect.Write as X import Cooked.MockChain.Run.Instances as X diff --git a/src/Cooked/MockChain/Effect/Read/Chain.hs b/src/Cooked/MockChain/Effect/Read/Chain.hs index 6197eddb2..2cc69064e 100644 --- a/src/Cooked/MockChain/Effect/Read/Chain.hs +++ b/src/Cooked/MockChain/Effect/Read/Chain.hs @@ -1,9 +1,11 @@ -- | 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. +-- of the blockchain, such as the available UTxOs, and the current constitution +-- or rewards. Time-related queries live in the separate +-- 'Cooked.MockChain.Effect.Time.MockChainTime' effect. 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, @@ -17,14 +19,6 @@ module Cooked.MockChain.Effect.Read.Chain txSkelInputScripts, txSkelInputValue, - -- * Queries related to time - currentSlot, - currentMSRange, - getEnclosingSlot, - slotRangeBefore, - slotRangeAfter, - slotToMSRange, - -- * Queries related to fetching UTxOs allUtxos, utxosAt, @@ -45,7 +39,6 @@ where import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano hiding (TxIn) import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Cardano.Slotting.Time qualified as Time import Control.Monad import Cooked.MockChain.Automation.GenerateTx.Credential import Cooked.MockChain.Common @@ -60,10 +53,7 @@ import Data.Map.Optics (toMapOf) import Data.Maybe import Data.Maybe.Strict import Data.Set qualified as Set -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 @@ -72,7 +62,6 @@ import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api import Polysemy import Polysemy.Error -import Polysemy.Fail import Polysemy.Reader import Polysemy.State @@ -84,9 +73,6 @@ import Polysemy.State -- 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) @@ -127,54 +113,6 @@ txSkelInputValue = . Map.keys . txSkelInputs --- | Returns the current slot -currentSlot :: - (Member MockChainReadChain effs) => - Sem effs P.Ledger.Slot - --- | Returns the closed ms interval corresponding to the slot with the given --- number. -slotToMSRange :: - (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 '[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 MockChainReadChain effs) => - Api.POSIXTime -> - Sem effs P.Ledger.Slot - --- | The infinite range of slots ending before or at the given time -slotRangeBefore :: - (Members '[MockChainReadChain, Fail] effs) => - Api.POSIXTime -> - Sem effs P.Ledger.SlotRange -slotRangeBefore t = do - n <- getEnclosingSlot t - (_, b) <- slotToMSRange n - -- If the given time @t@ happens to be the last ms of its slot, we can include - -- the whole slot. Otherwise, the only way to be sure that the returned slot - -- range contains no time after @t@ is to go to the preceding slot. - return $ Api.to $ if t == b then n else n - 1 - --- | The infinite range of slots starting after or at the given time -slotRangeAfter :: - (Members '[MockChainReadChain, Fail] effs) => - Api.POSIXTime -> - Sem effs P.Ledger.SlotRange -slotRangeAfter t = do - n <- getEnclosingSlot t - (a, _) <- slotToMSRange n - return $ Api.from $ if t == a then n else n + 1 - -- | Returns a list of all currently known outputs allUtxos :: (Member MockChainReadChain effs) => @@ -260,8 +198,7 @@ runMockChainReadChainEmul :: '[ State EmulatorState, State ChainIndex, Error P.Ledger.ToCardanoError, - Error MockChainError, - Fail + Error MockChainError ] effs ) => @@ -275,19 +212,6 @@ runMockChainReadChainEmul = interpret $ \case _ -> throw $ MCEUnknownOutRef oRef AllUtxos -> fetchUtxos $ const True UtxosAt (Script.toAddress -> addr) -> fetchUtxos $ (== addr) . Script.toAddress - CurrentSlot -> gets $ view $ emulatorStateLedgerStateL % to Emulator.getSlot - SlotToMSRange slot -> do - slotConfig <- gets $ Emulator.pSlotConfig . emulatorStateParams - 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 . emulatorStateParams GetConstitutionScript -> gets $ view chainIndexConstitutionL GetCurrentReward (Script.toCredential -> cred) -> do stakeCredential <- toStakeCredential cred @@ -320,7 +244,6 @@ runMockChainReadChainNode :: Error Cardano.UnsupportedNtcVersionError, Error Cardano.EraMismatch, Error Cardano.AcquiringFailure, - Error Cardano.PastHorizonException, Error P.Ledger.ToCardanoError, Error MockChainError, Reader Cardano.LocalNodeConnectInfo, @@ -331,19 +254,6 @@ runMockChainReadChainNode :: Sem (MockChainReadChain : effs) a -> Sem effs a runMockChainReadChainNode = interpret $ \case - CurrentSlot -> ask >>= fmap chainTipSlot . embed . Cardano.getLocalChainTip - SlotToMSRange slot -> do - 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 <- 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 <- getNetworkId @@ -425,17 +335,6 @@ runMockChainReadChainNode = interpret $ \case 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 - -- 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) - -- 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 diff --git a/src/Cooked/MockChain/Effect/Submission.hs b/src/Cooked/MockChain/Effect/Submission.hs index 5529630e2..5193e42b1 100644 --- a/src/Cooked/MockChain/Effect/Submission.hs +++ b/src/Cooked/MockChain/Effect/Submission.hs @@ -14,8 +14,6 @@ module Cooked.MockChain.Effect.Submission 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 Cooked.MockChain.Common @@ -30,6 +28,7 @@ import Polysemy.Fail import Polysemy.Reader import Polysemy.State +-- | An effect allow to submit a transaction for validation data MockChainSubmit :: Effect where SubmitTransaction :: Transaction -> MockChainSubmit m SubmissionFailures @@ -40,7 +39,7 @@ makeSem_ ''MockChainSubmit submitTransaction :: (Member MockChainSubmit effs) => Transaction -> - Sem effs [Conway.ConwayLedgerPredFailure Conway.ConwayEra] + Sem effs SubmissionFailures -- | Interprets the `MockChainSubmit` effect on an emulator runMockChainSubmitEmul :: diff --git a/src/Cooked/MockChain/Effect/Time.hs b/src/Cooked/MockChain/Effect/Time.hs new file mode 100644 index 000000000..46abd4063 --- /dev/null +++ b/src/Cooked/MockChain/Effect/Time.hs @@ -0,0 +1,238 @@ +-- | This module exposes the user-facing primitives to query and manipulate the +-- current time of the blockchain, expressed in terms of slots and POSIX time. +-- It regroups the time-related read primitives (the current slot, the +-- conversions between slots and POSIX time ranges) as well as the primitives to +-- wait for a given slot or time. The lower-level configuration primitives (era +-- history and system start) live in the internal +-- 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect, which the node +-- interpreter of this effect relies on. +module Cooked.MockChain.Effect.Time + ( -- * The 'MockChainTime' effect + MockChainTime, + + -- * 'MockChainTime' interpreters + runMockChainTimeEmul, + runMockChainTimeNode, + + -- * Queries related to the current time + currentSlot, + currentMSRange, + getEnclosingSlot, + slotRangeBefore, + slotRangeAfter, + slotToMSRange, + + -- * Modifications of the current time + waitNSlots, + awaitSlot, + awaitEnclosingSlot, + waitNMSFromSlotLowerBound, + waitNMSFromSlotUpperBound, + ) +where + +import Cardano.Api qualified as Cardano +import Cardano.Node.Emulator.Internal.Node qualified as Emulator +import Cardano.Slotting.Time qualified as Time +import Control.Concurrent (threadDelay) +import Control.Lens qualified as Lens +import Control.Monad +import Cooked.MockChain.Effect.Read.Conf +import Cooked.MockChain.Runtime.State +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Ledger.Slot qualified as P.Ledger +import Optics.Core +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, convert, and wait on the current +-- time of the mockchain. The read-only primitives ('currentSlot', +-- 'slotToMSRange', 'getEnclosingSlot') do not alter the state, while the waiting +-- primitive ('waitNSlots') advances the current slot. +data MockChainTime :: Effect where + CurrentSlot :: MockChainTime m P.Ledger.Slot + SlotToMSRange :: P.Ledger.Slot -> MockChainTime m (Api.POSIXTime, Api.POSIXTime) + GetEnclosingSlot :: Api.POSIXTime -> MockChainTime m P.Ledger.Slot + WaitNSlots :: Integer -> MockChainTime m P.Ledger.Slot + +makeSem_ ''MockChainTime + +-- | Returns the current slot +currentSlot :: + (Member MockChainTime effs) => + Sem effs P.Ledger.Slot + +-- | Returns the closed ms interval corresponding to the slot with the given +-- number. +slotToMSRange :: + (Members '[MockChainTime, Fail] effs) => + P.Ledger.Slot -> + Sem effs (Api.POSIXTime, Api.POSIXTime) + +-- | Returns the closed ms interval corresponding to the current slot +currentMSRange :: + (Members '[MockChainTime, 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 MockChainTime effs) => + Api.POSIXTime -> + Sem effs P.Ledger.Slot + +-- | The infinite range of slots ending before or at the given time +slotRangeBefore :: + (Members '[MockChainTime, Fail] effs) => + Api.POSIXTime -> + Sem effs P.Ledger.SlotRange +slotRangeBefore t = do + n <- getEnclosingSlot t + (_, b) <- slotToMSRange n + -- If the given time @t@ happens to be the last ms of its slot, we can include + -- the whole slot. Otherwise, the only way to be sure that the returned slot + -- range contains no time after @t@ is to go to the preceding slot. + return $ Api.to $ if t == b then n else n - 1 + +-- | The infinite range of slots starting after or at the given time +slotRangeAfter :: + (Members '[MockChainTime, Fail] effs) => + Api.POSIXTime -> + Sem effs P.Ledger.SlotRange +slotRangeAfter t = do + n <- getEnclosingSlot t + (a, _) <- slotToMSRange n + return $ Api.from $ if t == a then n else n + 1 + +-- | Waits a certain number of slots and returns the new slot +waitNSlots :: + (Member MockChainTime effs) => + Integer -> + Sem effs P.Ledger.Slot + +-- | Wait for a certain slot, or throws an error if the slot is already past +awaitSlot :: (Member MockChainTime effs) => P.Ledger.Slot -> Sem effs P.Ledger.Slot +awaitSlot (P.Ledger.Slot targetSlot) = do + P.Ledger.Slot now <- currentSlot + waitNSlots (targetSlot - now) + +-- | 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 :: (Member MockChainTime 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 '[MockChainTime, 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 '[MockChainTime, Fail] effs) => Integer -> Sem effs P.Ledger.Slot +waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd + +-- | The interpretation for the time effect with a stored 'EmulatorState' +runMockChainTimeEmul :: + forall effs a. + ( Members + '[ State EmulatorState, + Fail + ] + effs + ) => + Sem (MockChainTime : effs) a -> + Sem effs a +runMockChainTimeEmul = interpret $ \case + CurrentSlot -> gets $ view $ emulatorStateLedgerStateL % to Emulator.getSlot + SlotToMSRange slot -> do + slotConfig <- gets $ Emulator.pSlotConfig . emulatorStateParams + 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 . emulatorStateParams + WaitNSlots n -> do + cs <- gets $ Emulator.getSlot . emulatorStateLedgerState + -- Waiting for a non-positive number of slots does not change the current + -- slot, and we simply return it unchanged. + if n <= 0 + then return cs + else do + let newSlot = cs + fromIntegral n + modify' $ over emulatorStateLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot + return newSlot + +-- | Interpret the `MockChainTime` 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`). Waiting is +-- performed by suspending the thread for the appropriate amount of time. The +-- fixed chain configuration is resolved through the internal +-- 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect. +runMockChainTimeNode :: + forall effs a. + ( Members + '[ Embed IO, + MockChainReadConf, + Error Cardano.PastHorizonException, + Reader Cardano.LocalNodeConnectInfo + ] + effs + ) => + Sem (MockChainTime : effs) a -> + Sem effs a +runMockChainTimeNode = interpret $ \case + CurrentSlot -> getNodeSlot + SlotToMSRange slot -> slotToMS slot + GetEnclosingSlot t -> do + eraHistory <- getEraHistory + systemStart <- getSystemStart + let relTime = Time.toRelativeTime systemStart $ posixTimeToUTC t + fromSlotNo <$> fromEither (Cardano.getSlotForRelativeTime relTime eraHistory) + WaitNSlots n -> do + P.Ledger.Slot cs <- getNodeSlot + let target = P.Ledger.Slot $ cs + n + -- We compute the POSIX time at which the target slot begins and suspend the + -- thread until we reach it, if it lies in the future. + (Api.POSIXTime targetMS, _) <- slotToMS target + nowUTC <- embed getCurrentTime + let diff = diffUTCTime (posixTimeToUTC (Api.POSIXTime targetMS)) nowUTC + when (diff > 0) $ embed $ threadDelay $ round $ diff * 1000000 + return $ P.Ledger.Slot $ max cs (cs + n) + where + -- Retrieves the current slot from the local node chain tip + getNodeSlot :: Sem effs P.Ledger.Slot + getNodeSlot = do + conn <- ask + chainTip <- embed $ Cardano.getLocalChainTip conn + return $ case chainTip of + Cardano.ChainTipAtGenesis -> P.Ledger.Slot 0 + (Cardano.ChainTip slotNo _ _) -> fromSlotNo slotNo + -- Converts a slot into the closed POSIX ms interval it spans + slotToMS :: P.Ledger.Slot -> Sem effs (Api.POSIXTime, Api.POSIXTime) + slotToMS slot = do + 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) + -- 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) + -- 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 diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/MockChain/Effect/Write.hs index 7b779510f..7f6206ef7 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/MockChain/Effect/Write.hs @@ -7,13 +7,6 @@ module Cooked.MockChain.Effect.Write MockChainWrite (..), runMockChainWrite, - -- * Modifications of the current time - waitNSlots, - awaitSlot, - awaitEnclosingSlot, - waitNMSFromSlotLowerBound, - waitNMSFromSlotUpperBound, - -- * Other operations setParams, setConstitutionScript, @@ -40,21 +33,17 @@ import Cooked.Skeleton import Data.Map.Strict qualified as Map import Ledger.Index qualified as P.Ledger import Ledger.Orphans () -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.Scripts qualified as Script -import PlutusLedgerApi.V3 qualified as Api import Polysemy import Polysemy.Error -import Polysemy.Fail import Polysemy.State -- | An effect that offers all the primitives that are performing modifications -- on the blockchain state. data MockChainWrite :: Effect where - WaitNSlots :: Integer -> MockChainWrite m P.Ledger.Slot SetParams :: Emulator.Params -> MockChainWrite m () SetConstitutionScript :: (ToVScript s) => s -> MockChainWrite m () ForceOutputs :: [TxSkelOut] -> MockChainWrite m Utxos @@ -81,15 +70,6 @@ runMockChainWrite = interpret $ \case SetParams params -> do modify $ set emulatorStateParamsL params modify $ over emulatorStateLedgerStateL $ Emulator.updateStateParams params - WaitNSlots n -> do - 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 - return newSlot - | otherwise -> throw $ MCEPastSlot cs $ cs + fromIntegral n SetConstitutionScript (toVScript -> cScript) -> do modify' $ chainIndexConstitutionL ?~ cScript modify' $ @@ -121,31 +101,6 @@ runMockChainWrite = interpret $ \case -- Finally, we return the created utxos 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 - --- | Wait for a certain slot, or throws an error if the slot is already past -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) - --- | 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 '[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 '[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 '[MockChainReadChain, MockChainWrite, Fail] effs) => Integer -> Sem effs P.Ledger.Slot -waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd - -- | 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 9390c73c8..0b247aa70 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -53,6 +53,7 @@ import Cooked.MockChain.Effect.Misc import Cooked.MockChain.Effect.Read.Chain import Cooked.MockChain.Effect.Read.Conf import Cooked.MockChain.Effect.Submission +import Cooked.MockChain.Effect.Time import Cooked.MockChain.Effect.Validation import Cooked.MockChain.Effect.Write import Cooked.MockChain.Run.Runnable @@ -74,6 +75,7 @@ type DirectEffs = '[ MockChainValidate, MockChainWrite, MockChainReadChain, + MockChainTime, MockChainMisc, Fail ] @@ -94,6 +96,7 @@ instance RunnableMockChain DirectEffs where . runFailInMockChainError . runMockChainMisc fromAlias fromNote fromAssert . runMockChainReadConfEmul + . runMockChainTimeEmul . runMockChainReadChainEmul . runMockChainWrite . runMockChainSubmitEmul @@ -101,7 +104,7 @@ instance RunnableMockChain DirectEffs where . insertAt @1 @'[ MockChainSubmit ] - . insertAt @6 + . insertAt @7 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, State EmulatorState, @@ -109,7 +112,7 @@ instance RunnableMockChain DirectEffs where MockChainLog, Writer MockChainJournal ] - . insertAt @3 + . insertAt @4 @'[ MockChainReadConf ] @@ -118,6 +121,7 @@ instance RunnableMockChain DirectEffs where type FullTweakEffs = '[ MockChainMisc, MockChainReadChain, + MockChainTime, MockChainReadConf, Fail, Error P.Ledger.ToCardanoError, @@ -141,6 +145,7 @@ type FullEffs = State [Ltl (UntypedTweak FullTweakEffs)], MockChainMisc, MockChainReadChain, + MockChainTime, MockChainReadConf, Fail, Error P.Ledger.ToCardanoError, @@ -167,6 +172,7 @@ instance RunnableMockChain FullEffs where . runToCardanoErrorInMockChainError . runFailInMockChainError . runMockChainReadConfEmul + . runMockChainTimeEmul . runMockChainReadChainEmul . runMockChainMisc fromAlias fromNote fromAssert . evalState [] @@ -186,6 +192,7 @@ type ExtendedStagedTweakEffs extraEff = '[ extraEff, MockChainMisc, MockChainReadChain, + MockChainTime, Fail ] @@ -202,6 +209,7 @@ type ExtendedStagedEffs extraEff = extraEff, MockChainMisc, MockChainReadChain, + MockChainTime, Fail, NonDet ] @@ -227,6 +235,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runToCardanoErrorInMockChainError . runFailInMockChainError . runMockChainReadConfEmul + . runMockChainTimeEmul . runMockChainReadChainEmul . runMockChainMisc fromAlias fromNote fromAssert . runInterpretAlone @@ -238,7 +247,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . insertAt @1 @'[ MockChainSubmit ] - . insertAt @9 + . insertAt @10 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, State EmulatorState, @@ -247,7 +256,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr Writer MockChainJournal ] . reinterpretMockChainValidateWithTweak @(ExtendedStagedTweakEffs extraEff) - . insertAt @7 + . insertAt @8 @'[ MockChainReadConf ] . runModifyGlobally diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/MockChain/Runtime/Error.hs index 30775baff..98cdee7ee 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/MockChain/Runtime/Error.hs @@ -12,7 +12,6 @@ where import Cooked.MockChain.Common import Cooked.Skeleton.User -import Ledger.Slot qualified as P.Ledger import Ledger.Tx qualified as P.Ledger import PlutusLedgerApi.V3 qualified as Api import Polysemy @@ -52,8 +51,6 @@ data MockChainError MCEWrongReferenceScriptError Api.TxOutRef Api.ScriptHash (Maybe Api.ScriptHash) | -- | A UTxO is missing from the mockchain state MCEUnknownOutRef Api.TxOutRef - | -- | A jump in time would result in a past slot - 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 diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index fa40685e4..45435884c 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -113,11 +113,6 @@ instance PrettyCooked MockChainError where <+> "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 - <+> "; target slot:" - <+> PP.viaShow target prettyCookedOpt _ (MCEFailure msg) = "Failed with:" <+> PP.pretty msg instance PrettyCooked (Contextualized [MockChainLogEntry]) where diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index 1d88ef29a..c4d92125f 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.Chain +import Cooked.MockChain.Effect.Time import Cooked.MockChain.Runtime.Error import Cooked.MockChain.Runtime.State import Data.Default @@ -16,7 +16,7 @@ import Test.Tasty.QuickCheck runSlot :: Sem - '[ MockChainReadChain, + '[ MockChainTime, State EmulatorState, State ChainIndex, Fail, @@ -32,7 +32,7 @@ runSlot = . runFailInMockChainError . evalState def . evalState def - . runMockChainReadChainEmul + . runMockChainTimeEmul tests :: TestTree tests = From 3b5bac87ce14515c1da9a1fd6781ac62796fc3b0 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 14:38:58 +0200 Subject: [PATCH 21/39] Rename effect interpreters by backend prefix instead of suffix Distinguish effect interpreters by name rather than by an `Emul`/`Node` suffix: the emulated interpreters keep the `MockChain` prefix (runMockChainReadConf, runMockChainTime, runMockChainReadChain, runMockChainSubmit) while the node interpreters use a `BlockChain` prefix (runBlockChainReadConf, runBlockChainTime, runBlockChainReadChain, runBlockChainSubmit). Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Cooked/MockChain/Effect/Read/Chain.hs | 12 ++++----- src/Cooked/MockChain/Effect/Read/Conf.hs | 12 ++++----- src/Cooked/MockChain/Effect/Submission.hs | 12 ++++----- src/Cooked/MockChain/Effect/Time.hs | 12 ++++----- src/Cooked/MockChain/Run/Instances.hs | 30 +++++++++++------------ src/Cooked/MockChain/Runtime/Error.hs | 11 +-------- tests/Spec/Slot.hs | 4 +-- 7 files changed, 42 insertions(+), 51 deletions(-) diff --git a/src/Cooked/MockChain/Effect/Read/Chain.hs b/src/Cooked/MockChain/Effect/Read/Chain.hs index 2cc69064e..80e031e80 100644 --- a/src/Cooked/MockChain/Effect/Read/Chain.hs +++ b/src/Cooked/MockChain/Effect/Read/Chain.hs @@ -11,8 +11,8 @@ module Cooked.MockChain.Effect.Read.Chain MockChainReadChain, -- * 'MockChainReadChain' interpreters - runMockChainReadChainEmul, - runMockChainReadChainNode, + runMockChainReadChain, + runBlockChainReadChain, -- * Queries related to `Cooked.Skeleton.TxSkel` txSkelAllScripts, @@ -192,7 +192,7 @@ getCurrentReward :: -- | The interpretation for read-only effect with a stored 'EmulatorState' and -- 'ChainIndex' -runMockChainReadChainEmul :: +runMockChainReadChain :: forall effs a. ( Members '[ State EmulatorState, @@ -204,7 +204,7 @@ runMockChainReadChainEmul :: ) => Sem (MockChainReadChain : effs) a -> Sem effs a -runMockChainReadChainEmul = interpret $ \case +runMockChainReadChain = interpret $ \case TxSkelOutByRef oRef -> do res <- gets $ Map.lookup oRef . chainIndexOutputs case res of @@ -236,7 +236,7 @@ runMockChainReadChainEmul = interpret $ \case -- 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 :: +runBlockChainReadChain :: forall effs a. ( Members '[ Embed IO, @@ -253,7 +253,7 @@ runMockChainReadChainNode :: ) => Sem (MockChainReadChain : effs) a -> Sem effs a -runMockChainReadChainNode = interpret $ \case +runBlockChainReadChain = interpret $ \case AllUtxos -> queryUtxosAndHandleErrors Cardano.QueryUTxOWhole UtxosAt (Script.toAddress -> addr) -> do networkId <- getNetworkId diff --git a/src/Cooked/MockChain/Effect/Read/Conf.hs b/src/Cooked/MockChain/Effect/Read/Conf.hs index 847057973..660cb085a 100644 --- a/src/Cooked/MockChain/Effect/Read/Conf.hs +++ b/src/Cooked/MockChain/Effect/Read/Conf.hs @@ -10,8 +10,8 @@ module Cooked.MockChain.Effect.Read.Conf MockChainReadConf, -- * 'MockChainReadConf' interpreters - runMockChainReadConfEmul, - runMockChainReadConfNode, + runMockChainReadConf, + runBlockChainReadConf, -- * Queries related to protocol parameters getParams, @@ -64,11 +64,11 @@ makeSem_ ''MockChainReadConf -- | The interpretation for the configuration effect with a stored -- 'EmulatorState' -runMockChainReadConfEmul :: +runMockChainReadConf :: (Member (State EmulatorState) effs) => Sem (MockChainReadConf : effs) a -> Sem effs a -runMockChainReadConfEmul = interpret $ \case +runMockChainReadConf = interpret $ \case GetParams -> gets $ Emulator.pEmulatorPParams . emulatorStateParams GetNetworkId -> gets $ Emulator.pNetworkId . emulatorStateParams GetEraHistory -> gets $ Emulator.emulatorEraHistory . emulatorStateParams @@ -77,7 +77,7 @@ runMockChainReadConfEmul = interpret $ \case -- | 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 :: +runBlockChainReadConf :: ( Members '[ Embed IO, Error Cardano.UnsupportedNtcVersionError, @@ -89,7 +89,7 @@ runMockChainReadConfNode :: ) => Sem (MockChainReadConf : effs) a -> Sem effs a -runMockChainReadConfNode = interpret $ \case +runBlockChainReadConf = interpret $ \case GetParams -> queryAndHandleErrors $ Cardano.queryProtocolParameters Cardano.ShelleyBasedEraConway GetNetworkId -> asks Cardano.localNodeNetworkId GetEraHistory -> queryAndHandleError Cardano.queryEraHistory diff --git a/src/Cooked/MockChain/Effect/Submission.hs b/src/Cooked/MockChain/Effect/Submission.hs index 5193e42b1..8a39fffa1 100644 --- a/src/Cooked/MockChain/Effect/Submission.hs +++ b/src/Cooked/MockChain/Effect/Submission.hs @@ -8,8 +8,8 @@ module Cooked.MockChain.Effect.Submission submitTransaction, -- * Interpretation functions - runMockChainSubmitEmul, - runMockChainSubmitNode, + runMockChainSubmit, + runBlockChainSubmit, ) where @@ -42,12 +42,12 @@ submitTransaction :: Sem effs SubmissionFailures -- | Interprets the `MockChainSubmit` effect on an emulator -runMockChainSubmitEmul :: +runMockChainSubmit :: forall effs a. (Member (State EmulatorState) effs) => Sem (MockChainSubmit : effs) a -> Sem effs a -runMockChainSubmitEmul = interpret $ \case +runMockChainSubmit = interpret $ \case SubmitTransaction cardanoTx -> do -- To run transaction validation we need a minimal ledger state eLedgerState <- gets emulatorStateLedgerState @@ -66,7 +66,7 @@ runMockChainSubmitEmul = interpret $ \case -- 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`). -runMockChainSubmitNode :: +runBlockChainSubmit :: forall effs a. ( Members '[ Embed IO, @@ -79,7 +79,7 @@ runMockChainSubmitNode :: ) => Sem (MockChainSubmit : effs) a -> Sem effs a -runMockChainSubmitNode = interpret $ \case +runBlockChainSubmit = interpret $ \case SubmitTransaction cardanoTx -> do -- We retrieve the local node connection info. conn <- ask diff --git a/src/Cooked/MockChain/Effect/Time.hs b/src/Cooked/MockChain/Effect/Time.hs index 46abd4063..21006e754 100644 --- a/src/Cooked/MockChain/Effect/Time.hs +++ b/src/Cooked/MockChain/Effect/Time.hs @@ -11,8 +11,8 @@ module Cooked.MockChain.Effect.Time MockChainTime, -- * 'MockChainTime' interpreters - runMockChainTimeEmul, - runMockChainTimeNode, + runMockChainTime, + runBlockChainTime, -- * Queries related to the current time currentSlot, @@ -139,7 +139,7 @@ waitNMSFromSlotUpperBound :: (Members '[MockChainTime, Fail] effs) => Integer -> waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd -- | The interpretation for the time effect with a stored 'EmulatorState' -runMockChainTimeEmul :: +runMockChainTime :: forall effs a. ( Members '[ State EmulatorState, @@ -149,7 +149,7 @@ runMockChainTimeEmul :: ) => Sem (MockChainTime : effs) a -> Sem effs a -runMockChainTimeEmul = interpret $ \case +runMockChainTime = interpret $ \case CurrentSlot -> gets $ view $ emulatorStateLedgerStateL % to Emulator.getSlot SlotToMSRange slot -> do slotConfig <- gets $ Emulator.pSlotConfig . emulatorStateParams @@ -180,7 +180,7 @@ runMockChainTimeEmul = interpret $ \case -- performed by suspending the thread for the appropriate amount of time. The -- fixed chain configuration is resolved through the internal -- 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect. -runMockChainTimeNode :: +runBlockChainTime :: forall effs a. ( Members '[ Embed IO, @@ -192,7 +192,7 @@ runMockChainTimeNode :: ) => Sem (MockChainTime : effs) a -> Sem effs a -runMockChainTimeNode = interpret $ \case +runBlockChainTime = interpret $ \case CurrentSlot -> getNodeSlot SlotToMSRange slot -> slotToMS slot GetEnclosingSlot t -> do diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index 0b247aa70..812c94bfb 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -92,14 +92,14 @@ instance RunnableMockChain DirectEffs where . runState ciInit . runState emInit . runError - . runToCardanoErrorInMockChainError + . mapError MCEToCardanoError . runFailInMockChainError . runMockChainMisc fromAlias fromNote fromAssert - . runMockChainReadConfEmul - . runMockChainTimeEmul - . runMockChainReadChainEmul + . runMockChainReadConf + . runMockChainTime + . runMockChainReadChain . runMockChainWrite - . runMockChainSubmitEmul + . runMockChainSubmit . runMockChainValidate . insertAt @1 @'[ MockChainSubmit @@ -169,16 +169,16 @@ instance RunnableMockChain FullEffs where . runState ciInit . runState emInit . runError - . runToCardanoErrorInMockChainError + . mapError MCEToCardanoError . runFailInMockChainError - . runMockChainReadConfEmul - . runMockChainTimeEmul - . runMockChainReadChainEmul + . runMockChainReadConf + . runMockChainTime + . runMockChainReadChain . runMockChainMisc fromAlias fromNote fromAssert . evalState [] . runModifyLocally . runMockChainWrite - . runMockChainSubmitEmul + . runMockChainSubmit . runMockChainValidate . insertAt @1 @'[ MockChainSubmit @@ -232,17 +232,17 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runState ciInit . runState emInit . runError - . runToCardanoErrorInMockChainError + . mapError MCEToCardanoError . runFailInMockChainError - . runMockChainReadConfEmul - . runMockChainTimeEmul - . runMockChainReadChainEmul + . runMockChainReadConf + . runMockChainTime + . runMockChainReadChain . runMockChainMisc fromAlias fromNote fromAssert . runInterpretAlone . evalState [] . runModifyLocally . runMockChainWrite - . runMockChainSubmitEmul + . runMockChainSubmit . runMockChainValidate . insertAt @1 @'[ MockChainSubmit diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/MockChain/Runtime/Error.hs index 98cdee7ee..6a05a6963 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/MockChain/Runtime/Error.hs @@ -4,8 +4,7 @@ module Cooked.MockChain.Runtime.Error BalancingError (..), MockChainError (..), - -- * Interpreting effects into `Error MockChainError` - runToCardanoErrorInMockChainError, + -- * Interpreting Fail into @Error MockChainError@ runFailInMockChainError, ) where @@ -63,14 +62,6 @@ data MockChainError MCEFailure String deriving (Show, Eq) --- | Interpreting `P.Ledger.ToCardanoError` in terms of `MockChainError` -runToCardanoErrorInMockChainError :: - forall effs a. - (Member (Error MockChainError) effs) => - Sem (Error P.Ledger.ToCardanoError : effs) a -> - Sem effs a -runToCardanoErrorInMockChainError = mapError MCEToCardanoError - -- | Interpreting failures in terms of `MockChainError` runFailInMockChainError :: forall effs a. diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index c4d92125f..3d5a5e1b9 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -28,11 +28,11 @@ runSlot :: runSlot = run . runError - . runToCardanoErrorInMockChainError + . mapError MCEToCardanoError . runFailInMockChainError . evalState def . evalState def - . runMockChainTimeEmul + . runMockChainTime tests :: TestTree tests = From 5e5df4ace14f7061ca2f6c7773e22ee06f192447 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 15:38:54 +0200 Subject: [PATCH 22/39] interpreting mockchainmisc on IO --- src/Cooked/MockChain/Effect/Misc.hs | 103 +++++++++++++++++++----- src/Cooked/MockChain/Run/Instances.hs | 6 +- src/Cooked/MockChain/Runtime/Journal.hs | 4 +- src/Cooked/MockChain/Testing.hs | 2 +- src/Cooked/Pretty/MockChain.hs | 2 +- 5 files changed, 89 insertions(+), 28 deletions(-) diff --git a/src/Cooked/MockChain/Effect/Misc.hs b/src/Cooked/MockChain/Effect/Misc.hs index fe2407c93..90a6de8cd 100644 --- a/src/Cooked/MockChain/Effect/Misc.hs +++ b/src/Cooked/MockChain/Effect/Misc.hs @@ -6,6 +6,7 @@ module Cooked.MockChain.Effect.Misc ( -- * Misc effect MockChainMisc (..), runMockChainMisc, + runBlockChainMisc, -- * Storing aliases for hashable elements define, @@ -21,40 +22,34 @@ module Cooked.MockChain.Effect.Misc -- * Asserting properties assert, assert', + assertP, + assertL, + assertW, + assertS, ) where +import Cooked.MockChain.Runtime.Journal import Cooked.Pretty.Class import Cooked.Pretty.Hashable import Cooked.Pretty.Options -import PlutusLedgerApi.V3 qualified as Api +import Data.Map qualified as Map import Polysemy +import Polysemy.Fail +import Polysemy.State import Polysemy.Writer +import Prettyprinter ((<+>)) import Prettyprinter qualified as PP +import Prettyprinter.Render.Text qualified as PP -- | An effect that corresponds to extra QOL capabilities of the MockChain data MockChainMisc :: Effect where Define :: (ToHash a) => String -> a -> MockChainMisc m a Note :: (PrettyCookedOpts -> DocCooked) -> MockChainMisc m () - Assert :: String -> Bool -> MockChainMisc m () + Assert :: (PrettyCookedOpts -> DocCooked) -> Bool -> MockChainMisc m () makeSem_ ''MockChainMisc --- | Interpreting a `MockChainMisc` in terms of a writer of @Map --- BuiltinByteString String@ -runMockChainMisc :: - forall effs a j. - (Member (Writer j) effs) => - (String -> Api.BuiltinByteString -> j) -> - ((PrettyCookedOpts -> DocCooked) -> j) -> - (String -> Bool -> j) -> - Sem (MockChainMisc : effs) a -> - Sem effs a -runMockChainMisc injectAlias injectNote injectPred = interpret $ \case - (Define name hashable) -> tell (injectAlias name $ toHash hashable) >> return hashable - (Note s) -> tell $ injectNote s - (Assert s b) -> tell $ injectPred s b - -- | Stores an alias matching a hashable data for pretty printing purpose define :: forall effs a. (Member MockChainMisc effs, ToHash a) => String -> a -> Sem effs a @@ -83,9 +78,75 @@ noteW = note . const . PP.viaShow noteS :: forall effs. (Member MockChainMisc effs) => String -> Sem effs () noteS = noteP --- | Ensures a specific property holds, sending the provided error message otherwise -assert :: forall effs. (Member MockChainMisc effs) => String -> Bool -> Sem effs () +-- | Ensures a specific property holds, rendering the provided message with the +-- ambient pretty-printing options otherwise +assert :: forall effs. (Member MockChainMisc effs) => (PrettyCookedOpts -> DocCooked) -> Bool -> Sem effs () + +-- | Like `assert`, but with a pretty-printable message +assertP :: forall effs s. (Member MockChainMisc effs, PrettyCooked s) => s -> Bool -> Sem effs () +assertP doc = assert (`prettyCookedOpt` doc) + +-- | Like `assert`, but with a pretty-printable message displayed as a list with +-- a title +assertL :: forall effs l. (Member MockChainMisc effs, PrettyCookedList l) => String -> l -> Bool -> Sem effs () +assertL title docs = assert $ \opts -> prettyItemize opts (prettyCooked title) "-" docs + +-- | Like `assert`, but with a showable message +assertW :: forall effs s. (Member MockChainMisc effs, Show s) => s -> Bool -> Sem effs () +assertW = assert . const . PP.viaShow --- | Ensures a specific property holds, with a default error message otherwise +-- | Like `assert`, but with a `String` message +assertS :: forall effs. (Member MockChainMisc effs) => String -> Bool -> Sem effs () +assertS = assertP + +-- | Like `assert`, but with a default error message assert' :: forall effs. (Member MockChainMisc effs) => Bool -> Sem effs () -assert' = assert "Assertion" +assert' = assertS "Assertion" + +-- | Interprets a `MockChainMisc` in terms of a writer in @j@ where @j@ can be +-- built from either of the three possible parameters of the 3 misc actions. The +-- 3 actions only update the state, which is only used at the end of the run. +runMockChainMisc :: + forall effs a. + (Member (Writer MockChainJournal) effs) => + Sem (MockChainMisc : effs) a -> + Sem effs a +runMockChainMisc = interpret $ \case + (Define name hashable) -> tell (fromAlias name $ toHash hashable) >> return hashable + (Note s) -> tell $ fromNote s + (Assert s b) -> tell $ fromAssert s b + +-- | Interprets a `MockChainMisc` in the context of a deployed node, running in a +-- stack featuring @IO@ (via `Embed`). Contrary to `runMockChainMisc`, which +-- gathers everything in a journal to be inspected at the end of the run, this +-- interpreter reacts immediately: +-- +-- * `Define` registers an alias in the ambient `PrettyCookedOpts`, so that every +-- subsequent rendering (later notes and assertions) benefits from it. +-- +-- * `Note` is rendered using the current `PrettyCookedOpts` and printed to the +-- standard output right away, then the run proceeds. +-- +-- * `Assert` prints the associated message. When the asserted property holds, +-- the run proceeds; otherwise the whole computation is stopped. +runBlockChainMisc :: + forall effs a. + ( Members + '[ Embed IO, + State PrettyCookedOpts, + Fail + ] + effs + ) => + Sem (MockChainMisc : effs) a -> + Sem effs a +runBlockChainMisc = interpret $ \case + Define name hashable -> do + modify $ addHashNames $ Map.singleton (toHash hashable) name + return hashable + Note s -> gets s >>= embed . PP.putDoc . (<> PP.line) + Assert s b -> do + doc <- gets s + if b + then embed $ PP.putDoc $ "✔" <+> doc <> PP.line + else fail $ renderString id $ "✘" <+> doc diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/MockChain/Run/Instances.hs index 812c94bfb..feb250326 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/MockChain/Run/Instances.hs @@ -94,7 +94,7 @@ instance RunnableMockChain DirectEffs where . runError . mapError MCEToCardanoError . runFailInMockChainError - . runMockChainMisc fromAlias fromNote fromAssert + . runMockChainMisc . runMockChainReadConf . runMockChainTime . runMockChainReadChain @@ -174,7 +174,7 @@ instance RunnableMockChain FullEffs where . runMockChainReadConf . runMockChainTime . runMockChainReadChain - . runMockChainMisc fromAlias fromNote fromAssert + . runMockChainMisc . evalState [] . runModifyLocally . runMockChainWrite @@ -237,7 +237,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runMockChainReadConf . runMockChainTime . runMockChainReadChain - . runMockChainMisc fromAlias fromNote fromAssert + . runMockChainMisc . runInterpretAlone . evalState [] . runModifyLocally diff --git a/src/Cooked/MockChain/Runtime/Journal.hs b/src/Cooked/MockChain/Runtime/Journal.hs index 6519cfd9f..e9ae5a005 100644 --- a/src/Cooked/MockChain/Runtime/Journal.hs +++ b/src/Cooked/MockChain/Runtime/Journal.hs @@ -28,7 +28,7 @@ data MockChainJournal where mcbNotes :: [PrettyCookedOpts -> DocCooked], -- | Assertions gathered during the run, alongside their associated error -- messages to display in case of failure - mcbAssertions :: [(String, Bool)] + mcbAssertions :: [(PrettyCookedOpts -> DocCooked, Bool)] } -> MockChainJournal @@ -52,5 +52,5 @@ fromNote :: (PrettyCookedOpts -> DocCooked) -> MockChainJournal fromNote s = mempty {mcbNotes = [s]} -- | Build a `MockChainJournal` from a single assertion and error message -fromAssert :: String -> Bool -> MockChainJournal +fromAssert :: (PrettyCookedOpts -> DocCooked) -> Bool -> MockChainJournal fromAssert s p = mempty {mcbAssertions = [(s, p)]} diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index b591b87bf..bf8264b44 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -338,7 +338,7 @@ testToProp Test {..} = ( \ret@(MockChainReturn outcome _ state (MockChainJournal mcLog names _ assertions)) -> let pcOpts = addHashNames names testPrettyOpts in testConjoin - [ testConjoin $ uncurry testBoolMsg <$> assertions, + [ testConjoin $ (\(msg, b) -> testBoolMsg (renderString id (msg pcOpts)) b) <$> assertions, testCounterexample (renderString (prettyCookedOpt pcOpts) ret) $ case outcome of diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index 45435884c..fb5324fef 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -49,7 +49,7 @@ instance (Show a) => PrettyCooked (MockChainReturn a) where | pcOptPrintLog opts && not (null entries) ] <> [ prettyItemize opts (if all snd assertions then "✅ Assertions:" else "❌ Assertions:") "-" $ - (\(s, b) -> (if b then "✔" else "✘") <+> prettyCookedOpt opts s) <$> assertions + (\(s, b) -> (if b then "✔" else "✘") <+> s opts) <$> assertions | pcOptPrintAssertions opts && not (null assertions) ] <> [ "🗑️" <+> prettyCookedOpt opts consumed From aa096d7593ce72e2aaa99f6845e954bc6447830f Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 16:32:42 +0200 Subject: [PATCH 23/39] refactor(mockchain): lift MockChain submodules up into Cooked Move the contents of src/Cooked/MockChain/ one level up into src/Cooked/, renaming the Cooked.MockChain.* module prefix to Cooked.*. Remove the Cooked.MockChain umbrella module; the top-level Cooked umbrella now imports each piece directly. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 71 +++++++++---------- src/Cooked.hs | 17 ++++- src/Cooked/{MockChain => }/Automation.hs | 44 ++++++------ .../Automation/AutoFilling/Constitution.hs | 6 +- .../Automation/AutoFilling/MinAda.hs | 10 +-- .../AutoFilling/ReferenceScripts.hs | 8 +-- .../Automation/AutoFilling/Withdrawals.hs | 6 +- .../{MockChain => }/Automation/Balancing.hs | 20 +++--- .../Automation/GenerateTx/Anchor.hs | 2 +- .../Automation/GenerateTx/Body.hs | 28 ++++---- .../Automation/GenerateTx/Certificate.hs | 12 ++-- .../Automation/GenerateTx/Collateral.hs | 10 +-- .../Automation/GenerateTx/Credential.hs | 2 +- .../Automation/GenerateTx/Input.hs | 8 +-- .../Automation/GenerateTx/Mint.hs | 8 +-- .../Automation/GenerateTx/Output.hs | 6 +- .../Automation/GenerateTx/Proposal.hs | 14 ++-- .../Automation/GenerateTx/ReferenceInputs.hs | 4 +- .../Automation/GenerateTx/Withdrawals.hs | 10 +-- .../Automation/GenerateTx/Witness.hs | 6 +- src/Cooked/{MockChain => }/Common.hs | 2 +- src/Cooked/{MockChain => }/Effect/Log.hs | 6 +- src/Cooked/{MockChain => }/Effect/Misc.hs | 4 +- .../{MockChain => }/Effect/Read/Chain.hs | 20 +++--- .../{MockChain => }/Effect/Read/Conf.hs | 10 +-- .../{MockChain => }/Effect/Submission.hs | 8 +-- src/Cooked/{MockChain => }/Effect/Time.hs | 10 +-- .../{MockChain => }/Effect/Validation.hs | 18 ++--- src/Cooked/{MockChain => }/Effect/Write.hs | 20 +++--- src/Cooked/MockChain.hs | 20 ------ src/Cooked/Pretty.hs | 2 +- src/Cooked/Pretty/MockChain.hs | 10 +-- src/Cooked/{MockChain => }/Run/Instances.hs | 28 ++++---- src/Cooked/{MockChain => }/Run/Runnable.hs | 37 +++++----- src/Cooked/{MockChain => }/Run/Tweak.hs | 4 +- src/Cooked/{MockChain => }/Runtime/Error.hs | 4 +- src/Cooked/{MockChain => }/Runtime/Journal.hs | 4 +- src/Cooked/{MockChain => }/Runtime/State.hs | 4 +- src/Cooked/Skeleton/Label.hs | 4 +- src/Cooked/Skeleton/Option.hs | 2 +- src/Cooked/{MockChain => }/Testing.hs | 16 ++--- src/Cooked/{MockChain => }/UtxoSearch.hs | 6 +- tests/Spec/Ltl.hs | 2 +- tests/Spec/Slot.hs | 6 +- 44 files changed, 265 insertions(+), 274 deletions(-) rename src/Cooked/{MockChain => }/Automation.hs (52%) rename src/Cooked/{MockChain => }/Automation/AutoFilling/Constitution.hs (90%) rename src/Cooked/{MockChain => }/Automation/AutoFilling/MinAda.hs (93%) rename src/Cooked/{MockChain => }/Automation/AutoFilling/ReferenceScripts.hs (94%) rename src/Cooked/{MockChain => }/Automation/AutoFilling/Withdrawals.hs (90%) rename src/Cooked/{MockChain => }/Automation/Balancing.hs (98%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Anchor.hs (94%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Body.hs (91%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Certificate.hs (94%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Collateral.hs (92%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Credential.hs (98%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Input.hs (91%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Mint.hs (88%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Output.hs (92%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Proposal.hs (95%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/ReferenceInputs.hs (93%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Withdrawals.hs (88%) rename src/Cooked/{MockChain => }/Automation/GenerateTx/Witness.hs (96%) rename src/Cooked/{MockChain => }/Common.hs (98%) rename src/Cooked/{MockChain => }/Effect/Log.hs (96%) rename src/Cooked/{MockChain => }/Effect/Misc.hs (98%) rename src/Cooked/{MockChain => }/Effect/Read/Chain.hs (95%) rename src/Cooked/{MockChain => }/Effect/Read/Conf.hs (96%) rename src/Cooked/{MockChain => }/Effect/Submission.hs (96%) rename src/Cooked/{MockChain => }/Effect/Time.hs (97%) rename src/Cooked/{MockChain => }/Effect/Validation.hs (95%) rename src/Cooked/{MockChain => }/Effect/Write.hs (90%) delete mode 100644 src/Cooked/MockChain.hs rename src/Cooked/{MockChain => }/Run/Instances.hs (93%) rename src/Cooked/{MockChain => }/Run/Runnable.hs (91%) rename src/Cooked/{MockChain => }/Run/Tweak.hs (98%) rename src/Cooked/{MockChain => }/Runtime/Error.hs (97%) rename src/Cooked/{MockChain => }/Runtime/Journal.hs (96%) rename src/Cooked/{MockChain => }/Runtime/State.hs (99%) rename src/Cooked/{MockChain => }/Testing.hs (98%) rename src/Cooked/{MockChain => }/UtxoSearch.hs (98%) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 00f6b9649..3063201d8 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -21,44 +21,35 @@ library Cooked.Attack.RedeemerTampering Cooked.Attack.TokenDuplication Cooked.Attack.ValidityTampering + Cooked.Automation + Cooked.Automation.AutoFilling.Constitution + Cooked.Automation.AutoFilling.MinAda + Cooked.Automation.AutoFilling.ReferenceScripts + Cooked.Automation.AutoFilling.Withdrawals + Cooked.Automation.Balancing + Cooked.Automation.GenerateTx.Anchor + Cooked.Automation.GenerateTx.Body + Cooked.Automation.GenerateTx.Certificate + Cooked.Automation.GenerateTx.Collateral + Cooked.Automation.GenerateTx.Credential + Cooked.Automation.GenerateTx.Input + Cooked.Automation.GenerateTx.Mint + Cooked.Automation.GenerateTx.Output + Cooked.Automation.GenerateTx.Proposal + Cooked.Automation.GenerateTx.ReferenceInputs + Cooked.Automation.GenerateTx.Withdrawals + Cooked.Automation.GenerateTx.Witness + Cooked.Common + Cooked.Effect.Log + Cooked.Effect.Misc + Cooked.Effect.Read.Chain + Cooked.Effect.Read.Conf + Cooked.Effect.Submission + Cooked.Effect.Time + Cooked.Effect.Validation + Cooked.Effect.Write Cooked.Families Cooked.Ltl - Cooked.MockChain - Cooked.MockChain.Automation - Cooked.MockChain.Automation.AutoFilling.Constitution - Cooked.MockChain.Automation.AutoFilling.MinAda - Cooked.MockChain.Automation.AutoFilling.ReferenceScripts - Cooked.MockChain.Automation.AutoFilling.Withdrawals - Cooked.MockChain.Automation.Balancing - Cooked.MockChain.Automation.GenerateTx.Anchor - Cooked.MockChain.Automation.GenerateTx.Body - Cooked.MockChain.Automation.GenerateTx.Certificate - Cooked.MockChain.Automation.GenerateTx.Collateral - Cooked.MockChain.Automation.GenerateTx.Credential - Cooked.MockChain.Automation.GenerateTx.Input - Cooked.MockChain.Automation.GenerateTx.Mint - Cooked.MockChain.Automation.GenerateTx.Output - Cooked.MockChain.Automation.GenerateTx.Proposal - Cooked.MockChain.Automation.GenerateTx.ReferenceInputs - Cooked.MockChain.Automation.GenerateTx.Withdrawals - Cooked.MockChain.Automation.GenerateTx.Witness - Cooked.MockChain.Common - Cooked.MockChain.Effect.Log - Cooked.MockChain.Effect.Misc - Cooked.MockChain.Effect.Read.Chain - Cooked.MockChain.Effect.Read.Conf - Cooked.MockChain.Effect.Submission - Cooked.MockChain.Effect.Time - Cooked.MockChain.Effect.Validation - Cooked.MockChain.Effect.Write - Cooked.MockChain.Run.Instances - Cooked.MockChain.Run.Runnable - Cooked.MockChain.Run.Tweak - Cooked.MockChain.Runtime.Error - Cooked.MockChain.Runtime.Journal - Cooked.MockChain.Runtime.State - Cooked.MockChain.Testing - Cooked.MockChain.UtxoSearch Cooked.Pretty Cooked.Pretty.Class Cooked.Pretty.Hashable @@ -66,6 +57,12 @@ library Cooked.Pretty.Options Cooked.Pretty.Plutus Cooked.Pretty.Skeleton + Cooked.Run.Instances + Cooked.Run.Runnable + Cooked.Run.Tweak + Cooked.Runtime.Error + Cooked.Runtime.Journal + Cooked.Runtime.State Cooked.ShowBS Cooked.Skeleton Cooked.Skeleton.Anchor @@ -82,6 +79,7 @@ library Cooked.Skeleton.ValidityRange Cooked.Skeleton.Value Cooked.Skeleton.Withdrawal + Cooked.Testing Cooked.Tweak Cooked.Tweak.Common Cooked.Tweak.Guard @@ -90,6 +88,7 @@ library Cooked.Tweak.Query Cooked.Tweak.Remove Cooked.Tweak.Update + Cooked.UtxoSearch Cooked.Wallet other-modules: Paths_cooked_validators diff --git a/src/Cooked.hs b/src/Cooked.hs index bde37fdfb..aa6d4c757 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -3,11 +3,26 @@ module Cooked (module X) where import Cooked.Attack as X +import Cooked.Automation as X +import Cooked.Common as X +import Cooked.Effect.Misc as X +import Cooked.Effect.Read.Chain as X +import Cooked.Effect.Read.Conf as X +import Cooked.Effect.Time as X +import Cooked.Effect.Validation as X +import Cooked.Effect.Write as X import Cooked.Families as X import Cooked.Ltl as X -import Cooked.MockChain as X import Cooked.Pretty as X +import Cooked.Run.Instances as X +import Cooked.Run.Runnable as X +import Cooked.Run.Tweak as X +import Cooked.Runtime.Error as X +import Cooked.Runtime.Journal as X +import Cooked.Runtime.State as X import Cooked.ShowBS as X import Cooked.Skeleton as X +import Cooked.Testing as X import Cooked.Tweak as X +import Cooked.UtxoSearch as X import Cooked.Wallet as X diff --git a/src/Cooked/MockChain/Automation.hs b/src/Cooked/Automation.hs similarity index 52% rename from src/Cooked/MockChain/Automation.hs rename to src/Cooked/Automation.hs index c43c78a7b..0ea4bb433 100644 --- a/src/Cooked/MockChain/Automation.hs +++ b/src/Cooked/Automation.hs @@ -2,34 +2,34 @@ -- `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 +module Cooked.Automation ( runAutomationPipeline, module X, ) 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 -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.Effect.Log -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.Error +import Cooked.Automation.AutoFilling.Constitution as X +import Cooked.Automation.AutoFilling.MinAda as X +import Cooked.Automation.AutoFilling.ReferenceScripts as X +import Cooked.Automation.AutoFilling.Withdrawals as X +import Cooked.Automation.Balancing as X +import Cooked.Automation.GenerateTx.Anchor as X +import Cooked.Automation.GenerateTx.Body as X +import Cooked.Automation.GenerateTx.Certificate as X +import Cooked.Automation.GenerateTx.Collateral as X +import Cooked.Automation.GenerateTx.Credential as X +import Cooked.Automation.GenerateTx.Input as X +import Cooked.Automation.GenerateTx.Mint as X +import Cooked.Automation.GenerateTx.Output as X +import Cooked.Automation.GenerateTx.Proposal as X +import Cooked.Automation.GenerateTx.ReferenceInputs as X +import Cooked.Automation.GenerateTx.Withdrawals as X +import Cooked.Automation.GenerateTx.Witness as X +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error import Cooked.Skeleton import Cooked.Tweak.Common import Ledger.Orphans () diff --git a/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs b/src/Cooked/Automation/AutoFilling/Constitution.hs similarity index 90% rename from src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs rename to src/Cooked/Automation/AutoFilling/Constitution.hs index e26e33b62..baf040c96 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/Constitution.hs +++ b/src/Cooked/Automation/AutoFilling/Constitution.hs @@ -1,15 +1,15 @@ -- | This module exposes a function to automatically fill the constitution -- scripts of the proposals in a 'Cooked.Skeleton.TxSkel' based on the current -- state of the blockchain. -module Cooked.MockChain.Automation.AutoFilling.Constitution +module Cooked.Automation.AutoFilling.Constitution ( autoFillConstitution, ) where import Control.Monad import Control.Monad.Extra -import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read.Chain +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update diff --git a/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs b/src/Cooked/Automation/AutoFilling/MinAda.hs similarity index 93% rename from src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs rename to src/Cooked/Automation/AutoFilling/MinAda.hs index f4e712654..beb488f7b 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/MinAda.hs +++ b/src/Cooked/Automation/AutoFilling/MinAda.hs @@ -1,7 +1,7 @@ -- | This module exposes functions to automatically adjust the ADA contained in -- the outputs of a 'Cooked.Skeleton.TxSkel' to satisfy the minimal amount -- required by the protocol parameters. -module Cooked.MockChain.Automation.AutoFilling.MinAda +module Cooked.Automation.AutoFilling.MinAda ( getTxSkelOutMinAda, toTxSkelOutWithMinAda, autoFillMinAda, @@ -11,10 +11,10 @@ where import Cardano.Api qualified as Cardano 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.Chain -import Cooked.MockChain.Effect.Read.Conf +import Cooked.Automation.GenerateTx.Output +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update diff --git a/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs similarity index 94% rename from src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs rename to src/Cooked/Automation/AutoFilling/ReferenceScripts.hs index fb7d48ad1..a71e8d9b3 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/ReferenceScripts.hs +++ b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs @@ -1,20 +1,20 @@ -- | This module exposes functions to automatically attach reference inputs -- carrying reference scripts to the redeemers of a 'Cooked.Skeleton.TxSkel', -- based on the current state of the blockchain. -module Cooked.MockChain.Automation.AutoFilling.ReferenceScripts +module Cooked.Automation.AutoFilling.ReferenceScripts ( updateRedeemedScript, autoFillReferenceScripts, ) where import Control.Monad -import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.UtxoSearch +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Query import Cooked.Tweak.Update +import Cooked.UtxoSearch import Data.List (find) import Data.Map qualified as Map import Data.Set qualified as Set diff --git a/src/Cooked/MockChain/Automation/AutoFilling/Withdrawals.hs b/src/Cooked/Automation/AutoFilling/Withdrawals.hs similarity index 90% rename from src/Cooked/MockChain/Automation/AutoFilling/Withdrawals.hs rename to src/Cooked/Automation/AutoFilling/Withdrawals.hs index 8e73398d1..122fda4d9 100644 --- a/src/Cooked/MockChain/Automation/AutoFilling/Withdrawals.hs +++ b/src/Cooked/Automation/AutoFilling/Withdrawals.hs @@ -1,12 +1,12 @@ -- | This module exposes a function to automatically fill the withdrawn amounts -- of a 'Cooked.Skeleton.TxSkel' based on the current state of the blockchain. -module Cooked.MockChain.Automation.AutoFilling.Withdrawals +module Cooked.Automation.AutoFilling.Withdrawals ( autoFillWithdrawalAmounts, ) where -import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read.Chain +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update diff --git a/src/Cooked/MockChain/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs similarity index 98% rename from src/Cooked/MockChain/Automation/Balancing.hs rename to src/Cooked/Automation/Balancing.hs index c041f9680..f160b5c85 100644 --- a/src/Cooked/MockChain/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -1,7 +1,7 @@ -- | This module handles auto-balancing of transaction skeleton. This includes -- computation of fees and collaterals because their computation cannot be -- separated from the balancing. -module Cooked.MockChain.Automation.Balancing +module Cooked.Automation.Balancing ( ExtendedTxSkel (..), balanceTxSkel, getMinAndMaxFee, @@ -14,16 +14,16 @@ import Cardano.Api.Ledger qualified as Cardano import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway import Control.Monad -import Cooked.MockChain.Automation.AutoFilling.MinAda -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.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.UtxoSearch +import Cooked.Automation.AutoFilling.MinAda +import Cooked.Automation.GenerateTx.Body +import Cooked.Automation.GenerateTx.Output +import Cooked.Common +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error import Cooked.Skeleton +import Cooked.UtxoSearch import Data.ByteString qualified as BS import Data.Foldable.Extra import Data.Map qualified as Map diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Anchor.hs b/src/Cooked/Automation/GenerateTx/Anchor.hs similarity index 94% rename from src/Cooked/MockChain/Automation/GenerateTx/Anchor.hs rename to src/Cooked/Automation/GenerateTx/Anchor.hs index c1ba9b049..9fcbbc946 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Anchor.hs +++ b/src/Cooked/Automation/GenerateTx/Anchor.hs @@ -1,5 +1,5 @@ -- | Transforming 'TxSkelAnchor' into its Cardano counterpart -module Cooked.MockChain.Automation.GenerateTx.Anchor (toCardanoAnchor) where +module Cooked.Automation.GenerateTx.Anchor (toCardanoAnchor) where import Cardano.Ledger.BaseTypes qualified as C.Ledger import Cardano.Ledger.Conway.Core qualified as Conway diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs b/src/Cooked/Automation/GenerateTx/Body.hs similarity index 91% rename from src/Cooked/MockChain/Automation/GenerateTx/Body.hs rename to src/Cooked/Automation/GenerateTx/Body.hs index 663ab7f2d..ca86e1184 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Body.hs +++ b/src/Cooked/Automation/GenerateTx/Body.hs @@ -1,6 +1,6 @@ -- | This modules exposes entry points to convert a 'TxSkel' into a fully -- fledged transaction body -module Cooked.MockChain.Automation.GenerateTx.Body +module Cooked.Automation.GenerateTx.Body ( txSkelToTxBody, txBodyContentToTxBody, txSkelToTxBodyContent, @@ -12,19 +12,19 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Monad -import Cooked.MockChain.Automation.GenerateTx.Certificate -import Cooked.MockChain.Automation.GenerateTx.Collateral -import Cooked.MockChain.Automation.GenerateTx.Input -import Cooked.MockChain.Automation.GenerateTx.Mint -import Cooked.MockChain.Automation.GenerateTx.Output -import Cooked.MockChain.Automation.GenerateTx.Proposal -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.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.Error +import Cooked.Automation.GenerateTx.Certificate +import Cooked.Automation.GenerateTx.Collateral +import Cooked.Automation.GenerateTx.Input +import Cooked.Automation.GenerateTx.Mint +import Cooked.Automation.GenerateTx.Output +import Cooked.Automation.GenerateTx.Proposal +import Cooked.Automation.GenerateTx.ReferenceInputs +import Cooked.Automation.GenerateTx.Withdrawals +import Cooked.Automation.GenerateTx.Witness +import Cooked.Common +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error import Cooked.Skeleton import Data.Bifunctor (first) import Data.Map qualified as Map diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs b/src/Cooked/Automation/GenerateTx/Certificate.hs similarity index 94% rename from src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs rename to src/Cooked/Automation/GenerateTx/Certificate.hs index 603d122a4..08176b254 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Certificate.hs +++ b/src/Cooked/Automation/GenerateTx/Certificate.hs @@ -1,17 +1,17 @@ -- | This module provide primitives to transform certificates from our skeleton -- to certificate in Cardano transaction bodies. -module Cooked.MockChain.Automation.GenerateTx.Certificate (toCertificates) where +module Cooked.Automation.GenerateTx.Certificate (toCertificates) where import Cardano.Api qualified as Cardano 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 Cooked.MockChain.Automation.GenerateTx.Credential -import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.Error +import Cooked.Automation.GenerateTx.Credential +import Cooked.Automation.GenerateTx.Witness +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error import Cooked.Skeleton.Certificate import Cooked.Skeleton.User import Data.Default diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Collateral.hs b/src/Cooked/Automation/GenerateTx/Collateral.hs similarity index 92% rename from src/Cooked/MockChain/Automation/GenerateTx/Collateral.hs rename to src/Cooked/Automation/GenerateTx/Collateral.hs index 918f03934..31b7d60a9 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Collateral.hs +++ b/src/Cooked/Automation/GenerateTx/Collateral.hs @@ -1,15 +1,15 @@ -- | This module exposes the generation of transaction collaterals, which -- consist of a collateral amount, collateral inputs and return collateral -module Cooked.MockChain.Automation.GenerateTx.Collateral +module Cooked.Automation.GenerateTx.Collateral ( toCollateralTriplet, ) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Automation.GenerateTx.Output -import Cooked.MockChain.Common -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Effect.Read.Conf +import Cooked.Automation.GenerateTx.Output +import Cooked.Common +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf import Cooked.Skeleton.Output import Cooked.Skeleton.Value import Data.Map qualified as Map diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Credential.hs b/src/Cooked/Automation/GenerateTx/Credential.hs similarity index 98% rename from src/Cooked/MockChain/Automation/GenerateTx/Credential.hs rename to src/Cooked/Automation/GenerateTx/Credential.hs index 0621c17d6..9e04f7f7f 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Credential.hs +++ b/src/Cooked/Automation/GenerateTx/Credential.hs @@ -1,5 +1,5 @@ -- | This module exposes the generation of various kinds of credentials -module Cooked.MockChain.Automation.GenerateTx.Credential +module Cooked.Automation.GenerateTx.Credential ( toRewardAccount, toCardanoCredential, toStakeCredential, diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs b/src/Cooked/Automation/GenerateTx/Input.hs similarity index 91% rename from src/Cooked/MockChain/Automation/GenerateTx/Input.hs rename to src/Cooked/Automation/GenerateTx/Input.hs index 637d6ac65..af029e901 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Input.hs +++ b/src/Cooked/Automation/GenerateTx/Input.hs @@ -1,10 +1,10 @@ -- | This module exposes the generation of transaction inputs -module Cooked.MockChain.Automation.GenerateTx.Input (toTxInAndWitness) where +module Cooked.Automation.GenerateTx.Input (toTxInAndWitness) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Runtime.Error +import Cooked.Automation.GenerateTx.Witness +import Cooked.Effect.Read.Chain +import Cooked.Runtime.Error import Cooked.Skeleton import Ledger.Tx.CardanoAPI qualified as P.Ledger import Optics.Core diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Mint.hs b/src/Cooked/Automation/GenerateTx/Mint.hs similarity index 88% rename from src/Cooked/MockChain/Automation/GenerateTx/Mint.hs rename to src/Cooked/Automation/GenerateTx/Mint.hs index 0ec5beca4..23c9da787 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Mint.hs +++ b/src/Cooked/Automation/GenerateTx/Mint.hs @@ -1,11 +1,11 @@ -- | This module exposes the generation of a transaction minted value -module Cooked.MockChain.Automation.GenerateTx.Mint (toMintValue) where +module Cooked.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.Chain -import Cooked.MockChain.Runtime.Error +import Cooked.Automation.GenerateTx.Witness +import Cooked.Effect.Read.Chain +import Cooked.Runtime.Error import Cooked.Skeleton.Mint import Cooked.Skeleton.User import Data.Map qualified as Map diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs b/src/Cooked/Automation/GenerateTx/Output.hs similarity index 92% rename from src/Cooked/MockChain/Automation/GenerateTx/Output.hs rename to src/Cooked/Automation/GenerateTx/Output.hs index f5584b6bb..cb3614d80 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Output.hs +++ b/src/Cooked/Automation/GenerateTx/Output.hs @@ -1,9 +1,9 @@ -- | This modules exposes the generation of transaction outputs -module Cooked.MockChain.Automation.GenerateTx.Output (toCardanoTxOut) where +module Cooked.Automation.GenerateTx.Output (toCardanoTxOut) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Effect.Read.Conf +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf import Cooked.Skeleton.Datum import Cooked.Skeleton.Output import Ledger.Tx.CardanoAPI qualified as P.Ledger diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Proposal.hs b/src/Cooked/Automation/GenerateTx/Proposal.hs similarity index 95% rename from src/Cooked/MockChain/Automation/GenerateTx/Proposal.hs rename to src/Cooked/Automation/GenerateTx/Proposal.hs index a9268ec72..7ca27e143 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Proposal.hs +++ b/src/Cooked/Automation/GenerateTx/Proposal.hs @@ -1,5 +1,5 @@ -- | This module exposes the generation of proposal procedures -module Cooked.MockChain.Automation.GenerateTx.Proposal (toProposalProcedures) where +module Cooked.Automation.GenerateTx.Proposal (toProposalProcedures) where import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano @@ -9,12 +9,12 @@ import Cardano.Ledger.Conway.Governance qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad -import Cooked.MockChain.Automation.GenerateTx.Anchor -import Cooked.MockChain.Automation.GenerateTx.Credential -import Cooked.MockChain.Automation.GenerateTx.Witness -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.Error +import Cooked.Automation.GenerateTx.Anchor +import Cooked.Automation.GenerateTx.Credential +import Cooked.Automation.GenerateTx.Witness +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error import Cooked.Skeleton.Proposal import Cooked.Skeleton.User import Data.Coerce diff --git a/src/Cooked/MockChain/Automation/GenerateTx/ReferenceInputs.hs b/src/Cooked/Automation/GenerateTx/ReferenceInputs.hs similarity index 93% rename from src/Cooked/MockChain/Automation/GenerateTx/ReferenceInputs.hs rename to src/Cooked/Automation/GenerateTx/ReferenceInputs.hs index 16a16b3d7..3fa90be1d 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/ReferenceInputs.hs +++ b/src/Cooked/Automation/GenerateTx/ReferenceInputs.hs @@ -1,8 +1,8 @@ -- | This module allows the generation of Cardano reference inputs -module Cooked.MockChain.Automation.GenerateTx.ReferenceInputs (toInsReference) where +module Cooked.Automation.GenerateTx.ReferenceInputs (toInsReference) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Effect.Read.Chain +import Cooked.Effect.Read.Chain import Cooked.Skeleton import Data.Map qualified as Map import Data.Set qualified as Set diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs b/src/Cooked/Automation/GenerateTx/Withdrawals.hs similarity index 88% rename from src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs rename to src/Cooked/Automation/GenerateTx/Withdrawals.hs index 56a1dbf4c..c2e52eae4 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Withdrawals.hs +++ b/src/Cooked/Automation/GenerateTx/Withdrawals.hs @@ -1,12 +1,12 @@ -- | This modules exposes the generation of withdrawals -module Cooked.MockChain.Automation.GenerateTx.Withdrawals (toWithdrawals) where +module Cooked.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.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.Error +import Cooked.Automation.GenerateTx.Witness +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error import Cooked.Skeleton.User import Cooked.Skeleton.Withdrawal import Data.Coerce diff --git a/src/Cooked/MockChain/Automation/GenerateTx/Witness.hs b/src/Cooked/Automation/GenerateTx/Witness.hs similarity index 96% rename from src/Cooked/MockChain/Automation/GenerateTx/Witness.hs rename to src/Cooked/Automation/GenerateTx/Witness.hs index d881911ce..1ec6c60a2 100644 --- a/src/Cooked/MockChain/Automation/GenerateTx/Witness.hs +++ b/src/Cooked/Automation/GenerateTx/Witness.hs @@ -1,13 +1,13 @@ -- | This module exposes the generation of key and script witnesses -module Cooked.MockChain.Automation.GenerateTx.Witness +module Cooked.Automation.GenerateTx.Witness ( toScriptWitness, toKeyWitness, ) where import Cardano.Api qualified as Cardano -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Runtime.Error +import Cooked.Effect.Read.Chain +import Cooked.Runtime.Error import Cooked.Skeleton import Ledger.Address qualified as P.Ledger import Ledger.Tx.CardanoAPI qualified as P.Ledger diff --git a/src/Cooked/MockChain/Common.hs b/src/Cooked/Common.hs similarity index 98% rename from src/Cooked/MockChain/Common.hs rename to src/Cooked/Common.hs index 158d9168e..d1539aaae 100644 --- a/src/Cooked/MockChain/Common.hs +++ b/src/Cooked/Common.hs @@ -1,5 +1,5 @@ -- | This module exposes some type aliases common to our MockChain library -module Cooked.MockChain.Common +module Cooked.Common ( -- * Type aliases Fee, CollateralIns, diff --git a/src/Cooked/MockChain/Effect/Log.hs b/src/Cooked/Effect/Log.hs similarity index 96% rename from src/Cooked/MockChain/Effect/Log.hs rename to src/Cooked/Effect/Log.hs index b270bb90d..991dcfdc3 100644 --- a/src/Cooked/MockChain/Effect/Log.hs +++ b/src/Cooked/Effect/Log.hs @@ -5,8 +5,8 @@ -- adjustment automatically done by \cooked-validators\ during the transaction -- processing phase. This effect is typically not available to users, and should -- solely be used to track internal events. To trace additional elements from a --- user's perspective, use `Cooked.MockChain.Effect.Misc.note` instead. -module Cooked.MockChain.Effect.Log +-- user's perspective, use `Cooked.Effect.Misc.note` instead. +module Cooked.Effect.Log ( -- * Logging events TxValidity (..), MockChainLogEntry (..), @@ -20,7 +20,7 @@ module Cooked.MockChain.Effect.Log ) where -import Cooked.MockChain.Common +import Cooked.Common import Cooked.Skeleton import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api diff --git a/src/Cooked/MockChain/Effect/Misc.hs b/src/Cooked/Effect/Misc.hs similarity index 98% rename from src/Cooked/MockChain/Effect/Misc.hs rename to src/Cooked/Effect/Misc.hs index 90a6de8cd..740af11bd 100644 --- a/src/Cooked/MockChain/Effect/Misc.hs +++ b/src/Cooked/Effect/Misc.hs @@ -2,7 +2,7 @@ -- | This module defines primitives that offer quality of life features when -- operating a mockchain without interacting with the mockchain state itself. -module Cooked.MockChain.Effect.Misc +module Cooked.Effect.Misc ( -- * Misc effect MockChainMisc (..), runMockChainMisc, @@ -29,10 +29,10 @@ module Cooked.MockChain.Effect.Misc ) where -import Cooked.MockChain.Runtime.Journal import Cooked.Pretty.Class import Cooked.Pretty.Hashable import Cooked.Pretty.Options +import Cooked.Runtime.Journal import Data.Map qualified as Map import Polysemy import Polysemy.Fail diff --git a/src/Cooked/MockChain/Effect/Read/Chain.hs b/src/Cooked/Effect/Read/Chain.hs similarity index 95% rename from src/Cooked/MockChain/Effect/Read/Chain.hs rename to src/Cooked/Effect/Read/Chain.hs index 80e031e80..01c60b891 100644 --- a/src/Cooked/MockChain/Effect/Read/Chain.hs +++ b/src/Cooked/Effect/Read/Chain.hs @@ -1,12 +1,12 @@ -- | This module exposes the user-facing primitives to query the current state -- of the blockchain, such as the available UTxOs, and the current constitution -- or rewards. Time-related queries live in the separate --- 'Cooked.MockChain.Effect.Time.MockChainTime' effect. The lower-level +-- 'Cooked.Effect.Time.MockChainTime' effect. 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 +-- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect, which this -- effect relies on during its own interpretation. -module Cooked.MockChain.Effect.Read.Chain +module Cooked.Effect.Read.Chain ( -- * The 'MockChainReadChain' effect MockChainReadChain, @@ -40,11 +40,11 @@ import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano hiding (TxIn) import Cardano.Node.Emulator.Internal.Node qualified as Emulator 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.Automation.GenerateTx.Credential +import Cooked.Common +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error +import Cooked.Runtime.State import Cooked.Skeleton import Data.Coerce (coerce) import Data.Map (Map) @@ -69,7 +69,7 @@ import Polysemy.State -- mockchain. As its name suggests, this effect is read-only and does not alter -- 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 +-- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect to resolve the -- fixed chain configuration. data MockChainReadChain :: Effect where TxSkelOutByRef :: Api.TxOutRef -> MockChainReadChain m TxSkelOut @@ -235,7 +235,7 @@ runMockChainReadChain = interpret $ \case -- 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. +-- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect. runBlockChainReadChain :: forall effs a. ( Members diff --git a/src/Cooked/MockChain/Effect/Read/Conf.hs b/src/Cooked/Effect/Read/Conf.hs similarity index 96% rename from src/Cooked/MockChain/Effect/Read/Conf.hs rename to src/Cooked/Effect/Read/Conf.hs index 660cb085a..3eed5bf19 100644 --- a/src/Cooked/MockChain/Effect/Read/Conf.hs +++ b/src/Cooked/Effect/Read/Conf.hs @@ -2,10 +2,10 @@ -- 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' +-- user-facing 'Cooked.Effect.Read.Chain.MockChainReadChain' effect, +-- and they are deliberately not meant to be used directly through the 'Cooked' -- umbrella module. -module Cooked.MockChain.Effect.Read.Conf +module Cooked.Effect.Read.Conf ( -- * The 'MockChainReadConf' effect MockChainReadConf, @@ -39,7 +39,7 @@ 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.Runtime.State import Cooked.Skeleton import Data.Functor import Optics.Core @@ -53,7 +53,7 @@ import Polysemy.State -- 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. +-- 'Cooked.Effect.Read.Chain.MockChainReadChain' effect. data MockChainReadConf :: Effect where GetParams :: MockChainReadConf m (C.Ledger.PParams Conway.ConwayEra) GetNetworkId :: MockChainReadConf m Cardano.NetworkId diff --git a/src/Cooked/MockChain/Effect/Submission.hs b/src/Cooked/Effect/Submission.hs similarity index 96% rename from src/Cooked/MockChain/Effect/Submission.hs rename to src/Cooked/Effect/Submission.hs index 8a39fffa1..8274eb6a4 100644 --- a/src/Cooked/MockChain/Effect/Submission.hs +++ b/src/Cooked/Effect/Submission.hs @@ -2,7 +2,7 @@ -- | This module exposes the 'MockChainSubmit' effect, which is responsible for -- submitting a Cardano transaction for validation. -module Cooked.MockChain.Effect.Submission +module Cooked.Effect.Submission ( -- * The 'MockChainSubmit' effect MockChainSubmit (..), submitTransaction, @@ -16,9 +16,9 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Shelley.API.Mempool qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Cooked.MockChain.Common -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.State +import Cooked.Common +import Cooked.Effect.Read.Conf +import Cooked.Runtime.State import Data.Foldable.Extra import Ledger.Orphans () import Optics.Core diff --git a/src/Cooked/MockChain/Effect/Time.hs b/src/Cooked/Effect/Time.hs similarity index 97% rename from src/Cooked/MockChain/Effect/Time.hs rename to src/Cooked/Effect/Time.hs index 21006e754..4778ca3bc 100644 --- a/src/Cooked/MockChain/Effect/Time.hs +++ b/src/Cooked/Effect/Time.hs @@ -4,9 +4,9 @@ -- conversions between slots and POSIX time ranges) as well as the primitives to -- wait for a given slot or time. The lower-level configuration primitives (era -- history and system start) live in the internal --- 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect, which the node +-- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect, which the node -- interpreter of this effect relies on. -module Cooked.MockChain.Effect.Time +module Cooked.Effect.Time ( -- * The 'MockChainTime' effect MockChainTime, @@ -37,8 +37,8 @@ import Cardano.Slotting.Time qualified as Time import Control.Concurrent (threadDelay) import Control.Lens qualified as Lens import Control.Monad -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.State +import Cooked.Effect.Read.Conf +import Cooked.Runtime.State import Data.Time.Clock import Data.Time.Clock.POSIX import Ledger.Slot qualified as P.Ledger @@ -179,7 +179,7 @@ runMockChainTime = interpret $ \case -- `Reader`, running in a stack featuring @IO@ (via `Embed`). Waiting is -- performed by suspending the thread for the appropriate amount of time. The -- fixed chain configuration is resolved through the internal --- 'Cooked.MockChain.Effect.Read.Conf.MockChainReadConf' effect. +-- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect. runBlockChainTime :: forall effs a. ( Members diff --git a/src/Cooked/MockChain/Effect/Validation.hs b/src/Cooked/Effect/Validation.hs similarity index 95% rename from src/Cooked/MockChain/Effect/Validation.hs rename to src/Cooked/Effect/Validation.hs index 131aeb8e4..ab2c8731b 100644 --- a/src/Cooked/MockChain/Effect/Validation.hs +++ b/src/Cooked/Effect/Validation.hs @@ -5,7 +5,7 @@ -- 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 +module Cooked.Effect.Validation ( -- * The `MockChainValidate` effect MockChainValidate (..), validateTxSkel, @@ -20,14 +20,14 @@ where import Cardano.Api qualified as Cardano import Control.Monad -import Cooked.MockChain.Automation -import Cooked.MockChain.Common -import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Read.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Effect.Submission -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.State +import Cooked.Automation +import Cooked.Common +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Effect.Submission +import Cooked.Runtime.Error +import Cooked.Runtime.State import Cooked.Skeleton import Data.Foldable.Extra import Data.Map.Strict qualified as Map diff --git a/src/Cooked/MockChain/Effect/Write.hs b/src/Cooked/Effect/Write.hs similarity index 90% rename from src/Cooked/MockChain/Effect/Write.hs rename to src/Cooked/Effect/Write.hs index 7f6206ef7..ab90459eb 100644 --- a/src/Cooked/MockChain/Effect/Write.hs +++ b/src/Cooked/Effect/Write.hs @@ -2,7 +2,7 @@ -- | This module exposes primitives to manually (and artificially) update the -- current state of the blockchain. -module Cooked.MockChain.Effect.Write +module Cooked.Effect.Write ( -- * The `MockChainWrite` effect MockChainWrite (..), runMockChainWrite, @@ -20,15 +20,15 @@ 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.MinAda -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.Chain -import Cooked.MockChain.Effect.Read.Conf -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.State +import Cooked.Automation.AutoFilling.MinAda +import Cooked.Automation.GenerateTx.Body +import Cooked.Automation.GenerateTx.Output +import Cooked.Common +import Cooked.Effect.Log +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Runtime.Error +import Cooked.Runtime.State import Cooked.Skeleton import Data.Map.Strict qualified as Map import Ledger.Index qualified as P.Ledger diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs deleted file mode 100644 index c413e3540..000000000 --- a/src/Cooked/MockChain.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | This module centralizes everything related to our mockchain, while hiding --- elements related to logs and inner state. -module Cooked.MockChain (module X) where - -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 -import Cooked.MockChain.Effect.Read.Conf as X -import Cooked.MockChain.Effect.Time 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 -import Cooked.MockChain.Run.Tweak as X -import Cooked.MockChain.Runtime.Error as X -import Cooked.MockChain.Runtime.Journal as X -import Cooked.MockChain.Runtime.State as X -import Cooked.MockChain.Testing as X -import Cooked.MockChain.UtxoSearch as X diff --git a/src/Cooked/Pretty.hs b/src/Cooked/Pretty.hs index 8d05bd03d..9e5d2a913 100644 --- a/src/Cooked/Pretty.hs +++ b/src/Cooked/Pretty.hs @@ -39,7 +39,7 @@ -- -- Pretty printing of transaction skeletons and UTxO states is done -- automatically by the end-user functions provided in --- "Cooked.MockChain.Testing". +-- "Cooked.Testing". -- -- To do it manually, use instances of 'PrettyCooked', 'PrettyCookedList' or -- 'PrettyCookedMaybe' defined in 'Cooked.Pretty.Skeleton' or diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index fb5324fef..31822704c 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -4,14 +4,14 @@ -- 'PrettyCookedMaybe' instances for data types returned by a @MockChain@ run. module Cooked.Pretty.MockChain () where -import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Run.Runnable -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.Journal -import Cooked.MockChain.Runtime.State +import Cooked.Effect.Log import Cooked.Pretty.Class import Cooked.Pretty.Options import Cooked.Pretty.Skeleton +import Cooked.Run.Runnable +import Cooked.Runtime.Error +import Cooked.Runtime.Journal +import Cooked.Runtime.State import Cooked.Skeleton.User import Cooked.Wallet (walletPKHashToId) import Data.Function (on) diff --git a/src/Cooked/MockChain/Run/Instances.hs b/src/Cooked/Run/Instances.hs similarity index 93% rename from src/Cooked/MockChain/Run/Instances.hs rename to src/Cooked/Run/Instances.hs index feb250326..b1f74b566 100644 --- a/src/Cooked/MockChain/Run/Instances.hs +++ b/src/Cooked/Run/Instances.hs @@ -21,7 +21,7 @@ -- including intermediate hidden in the other instances. This should only be -- used when explicitly executing internal primitives of cooked, such as -- balancing, is required. -module Cooked.MockChain.Run.Instances +module Cooked.Run.Instances ( -- * Direct, simple mockchain instance DirectEffs, DirectMockChain, @@ -47,20 +47,20 @@ module Cooked.MockChain.Run.Instances ) where +import Cooked.Effect.Log +import Cooked.Effect.Misc +import Cooked.Effect.Read.Chain +import Cooked.Effect.Read.Conf +import Cooked.Effect.Submission +import Cooked.Effect.Time +import Cooked.Effect.Validation +import Cooked.Effect.Write import Cooked.Ltl -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.Submission -import Cooked.MockChain.Effect.Time -import Cooked.MockChain.Effect.Validation -import Cooked.MockChain.Effect.Write -import Cooked.MockChain.Run.Runnable -import Cooked.MockChain.Run.Tweak -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.Journal -import Cooked.MockChain.Runtime.State +import Cooked.Run.Runnable +import Cooked.Run.Tweak +import Cooked.Runtime.Error +import Cooked.Runtime.Journal +import Cooked.Runtime.State import Ledger.Tx qualified as P.Ledger import Polysemy import Polysemy.Bundle diff --git a/src/Cooked/MockChain/Run/Runnable.hs b/src/Cooked/Run/Runnable.hs similarity index 91% rename from src/Cooked/MockChain/Run/Runnable.hs rename to src/Cooked/Run/Runnable.hs index 46bed059e..e0fb61231 100644 --- a/src/Cooked/MockChain/Run/Runnable.hs +++ b/src/Cooked/Run/Runnable.hs @@ -1,23 +1,22 @@ --- | This module exposes the infrastructure to execute mockchain runs. In --- particular: --- --- - The notion of initial distribution (a list of payments) --- --- - The return types of the runs (raw and refined) --- --- - The initial configuration with which to execute a run --- --- - The notion of `RunnableMockChain` to actually execute computations -module Cooked.MockChain.Run.Runnable - ( InitialDistribution, +-- | This module exposes the infrastructure to execute mockchain and blockchain +-- runs, in particular initial configurations, results, and running functions. +module Cooked.Run.Runnable + ( -- * Initial distributions + InitialDistribution, initialDistributionTemplate, distributionFromList, + + -- * Initial mockchain configurations + MockChainConf (..), + mockChainConfTemplate, + + -- * Mockchain run return type RawMockChainReturn, MockChainReturn (..), FunOnMockChainResult, unRawMockChainReturn, - MockChainConf (..), - mockChainConfTemplate, + + -- * Running mockchains RunnableMockChain (..), runMockChainFromConf, runMockChainFromInitDist, @@ -26,10 +25,10 @@ module Cooked.MockChain.Run.Runnable ) where -import Cooked.MockChain.Effect.Write -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.Journal -import Cooked.MockChain.Runtime.State +import Cooked.Effect.Write +import Cooked.Runtime.Error +import Cooked.Runtime.Journal +import Cooked.Runtime.State import Cooked.Skeleton.Output import Cooked.Wallet import Data.Default @@ -39,8 +38,6 @@ import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api import Polysemy --- * Initial distribution of funds - -- | Describes the initial distribution of UTxOs per user. -- -- The following specifies a starting state where @wallet 1@ owns two UTxOs, diff --git a/src/Cooked/MockChain/Run/Tweak.hs b/src/Cooked/Run/Tweak.hs similarity index 98% rename from src/Cooked/MockChain/Run/Tweak.hs rename to src/Cooked/Run/Tweak.hs index 0c5d520a6..51662f749 100644 --- a/src/Cooked/MockChain/Run/Tweak.hs +++ b/src/Cooked/Run/Tweak.hs @@ -1,6 +1,6 @@ -- | This module applies the `Cooked.Tweak.Common.Tweak` effect for the purpose -- of modifying transaction skeleton before sending them for validation. -module Cooked.MockChain.Run.Tweak +module Cooked.Run.Tweak ( -- * Modifying mockchain runs using tweaks reinterpretMockChainValidateWithTweak, @@ -19,8 +19,8 @@ module Cooked.MockChain.Run.Tweak where import Control.Monad +import Cooked.Effect.Validation import Cooked.Ltl -import Cooked.MockChain.Effect.Validation import Cooked.Tweak.Common import Polysemy import Polysemy.Internal diff --git a/src/Cooked/MockChain/Runtime/Error.hs b/src/Cooked/Runtime/Error.hs similarity index 97% rename from src/Cooked/MockChain/Runtime/Error.hs rename to src/Cooked/Runtime/Error.hs index 6a05a6963..6857d6aa9 100644 --- a/src/Cooked/MockChain/Runtime/Error.hs +++ b/src/Cooked/Runtime/Error.hs @@ -1,5 +1,5 @@ -- | This module exposes the errors that can be raised during a mockchain run -module Cooked.MockChain.Runtime.Error +module Cooked.Runtime.Error ( -- * Mockchain errors BalancingError (..), MockChainError (..), @@ -9,7 +9,7 @@ module Cooked.MockChain.Runtime.Error ) where -import Cooked.MockChain.Common +import Cooked.Common import Cooked.Skeleton.User import Ledger.Tx qualified as P.Ledger import PlutusLedgerApi.V3 qualified as Api diff --git a/src/Cooked/MockChain/Runtime/Journal.hs b/src/Cooked/Runtime/Journal.hs similarity index 96% rename from src/Cooked/MockChain/Runtime/Journal.hs rename to src/Cooked/Runtime/Journal.hs index e9ae5a005..182f4ecb9 100644 --- a/src/Cooked/MockChain/Runtime/Journal.hs +++ b/src/Cooked/Runtime/Journal.hs @@ -1,5 +1,5 @@ -- | This module exposes the various events emitted during a mockchain run. -module Cooked.MockChain.Runtime.Journal +module Cooked.Runtime.Journal ( MockChainJournal (..), fromLogEntry, fromAlias, @@ -8,7 +8,7 @@ module Cooked.MockChain.Runtime.Journal ) where -import Cooked.MockChain.Effect.Log +import Cooked.Effect.Log import Cooked.Pretty.Class import Cooked.Pretty.Options import Data.Map diff --git a/src/Cooked/MockChain/Runtime/State.hs b/src/Cooked/Runtime/State.hs similarity index 99% rename from src/Cooked/MockChain/Runtime/State.hs rename to src/Cooked/Runtime/State.hs index 55abdad60..c5700f90b 100644 --- a/src/Cooked/MockChain/Runtime/State.hs +++ b/src/Cooked/Runtime/State.hs @@ -20,7 +20,7 @@ -- - For testings purposes, when querying the final state of a run is -- 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 +module Cooked.Runtime.State ( -- * `EmulatorState` and associated optics EmulatorState (..), emulatorStateParamsL, @@ -78,7 +78,7 @@ import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api -- | The emulator-specific state used to run the simulation in --- 'Cooked.MockChain.Direct'. It only makes sense when running against the +-- 'Cooked.Direct'. It only makes sense when running against the -- emulated ledger. data EmulatorState where EmulatorState :: diff --git a/src/Cooked/Skeleton/Label.hs b/src/Cooked/Skeleton/Label.hs index 71cb463a9..c4930a7e6 100644 --- a/src/Cooked/Skeleton/Label.hs +++ b/src/Cooked/Skeleton/Label.hs @@ -28,7 +28,7 @@ type LabelConstrs x = (PrettyCooked x, Show x, Typeable x, Eq x, Ord x) -- skeletons that have been modified by tweaks and automated attacks. -- -- The 'IsString' instance will add a 'Data.Text.Text' label, which can --- be used with 'Cooked.MockChain.Staged.labelled' to apply tweaks +-- be used with 'Cooked.Staged.labelled' to apply tweaks -- to arbitrary transactions annotated with a label. data TxSkelLabel where TxSkelLabel :: (LabelConstrs x) => x -> TxSkelLabel @@ -60,6 +60,6 @@ txSkelLabelTypedP = TxSkelLabel (\txSkelLabel@(TxSkelLabel lbl) -> maybe (Left txSkelLabel) Right (cast lbl)) --- | Turn a literal string into a 'Data.Text.Text' label, to be used with 'Cooked.MockChain.Staged.labelled'. +-- | Turn a literal string into a 'Data.Text.Text' label, to be used with 'Cooked.Staged.labelled'. instance IsString TxSkelLabel where fromString = TxSkelLabel . pack diff --git a/src/Cooked/Skeleton/Option.hs b/src/Cooked/Skeleton/Option.hs index bf956370a..ae164eef5 100644 --- a/src/Cooked/Skeleton/Option.hs +++ b/src/Cooked/Skeleton/Option.hs @@ -29,7 +29,7 @@ module Cooked.Skeleton.Option ) where -import Cooked.MockChain.Common +import Cooked.Common import Data.Default import Data.Set (Set) import Data.Typeable diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/Testing.hs similarity index 98% rename from src/Cooked/MockChain/Testing.hs rename to src/Cooked/Testing.hs index bf8264b44..9538a9ec7 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/Testing.hs @@ -2,7 +2,7 @@ -- | This modules provides primitives to run tests over mockchain executions and -- to provide requirements on the the number and results of these runs. -module Cooked.MockChain.Testing +module Cooked.Testing ( -- * Common interface between HUnit and QuickCheck IsProp (..), testBool, @@ -88,13 +88,13 @@ where import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Exception qualified as E import Control.Monad -import Cooked.MockChain.Effect.Log -import Cooked.MockChain.Effect.Write -import Cooked.MockChain.Run.Runnable -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.Journal -import Cooked.MockChain.Runtime.State +import Cooked.Effect.Log +import Cooked.Effect.Write import Cooked.Pretty +import Cooked.Run.Runnable +import Cooked.Runtime.Error +import Cooked.Runtime.Journal +import Cooked.Runtime.State import Data.Default import Data.List (isInfixOf) import Data.Map qualified as Map @@ -396,7 +396,7 @@ testCookedQCFromInitDistTemplate name = -- | A test template which expects a success from a trace. This test template is -- built from a trace and a dedicated runner, to be used for runs that do not -- implement `RunnableMockChain`. One of the intended uses is for running --- `Cooked.MockChain.Instance.StagedInjectMockChain` when the additional effect +-- `Cooked.Instance.StagedInjectMockChain` when the additional effect -- results in a extended return value (such as a resulting state). mustSucceedTest' :: (IsProp prop) => diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/UtxoSearch.hs similarity index 98% rename from src/Cooked/MockChain/UtxoSearch.hs rename to src/Cooked/UtxoSearch.hs index 38ac57998..d2a583f98 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/src/Cooked/UtxoSearch.hs @@ -1,7 +1,7 @@ -- | This module provides a convenient framework to look through UTxOs and: -- - filter them in a convenient manner -- - extract pieces of information from them -module Cooked.MockChain.UtxoSearch +module Cooked.UtxoSearch ( -- * UTxO searches UtxoSearch, beginSearch, @@ -44,9 +44,9 @@ module Cooked.MockChain.UtxoSearch where import Control.Monad (foldM) +import Cooked.Common +import Cooked.Effect.Read.Chain 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 diff --git a/tests/Spec/Ltl.hs b/tests/Spec/Ltl.hs index 7aa73b9b6..0b4dd03c1 100644 --- a/tests/Spec/Ltl.hs +++ b/tests/Spec/Ltl.hs @@ -4,7 +4,7 @@ module Spec.Ltl where import Control.Monad (MonadPlus (..), guard, replicateM, void) import Cooked.Ltl -import Cooked.MockChain.Testing +import Cooked.Testing import Data.Maybe import Polysemy import Polysemy.NonDet diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index 3d5a5e1b9..ba850b117 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -1,8 +1,8 @@ module Spec.Slot (tests) where -import Cooked.MockChain.Effect.Time -import Cooked.MockChain.Runtime.Error -import Cooked.MockChain.Runtime.State +import Cooked.Effect.Time +import Cooked.Runtime.Error +import Cooked.Runtime.State import Data.Default import Ledger.Slot qualified as P.Ledger import Ledger.Tx qualified as P.Ledger From fad641d8e56c828f9ee5724689f662b41dede83d Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 16:34:56 +0200 Subject: [PATCH 24/39] refactor(mockchain): rename Cooked.Common to Cooked.Aliases Rename src/Cooked/Common.hs to src/Cooked/Aliases.hs and the module Cooked.Common to Cooked.Aliases. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 2 +- src/Cooked.hs | 2 +- src/Cooked/{Common.hs => Aliases.hs} | 4 ++-- src/Cooked/Automation/Balancing.hs | 2 +- src/Cooked/Automation/GenerateTx/Body.hs | 2 +- src/Cooked/Automation/GenerateTx/Collateral.hs | 2 +- src/Cooked/Effect/Log.hs | 2 +- src/Cooked/Effect/Read/Chain.hs | 2 +- src/Cooked/Effect/Submission.hs | 2 +- src/Cooked/Effect/Validation.hs | 2 +- src/Cooked/Effect/Write.hs | 2 +- src/Cooked/Runtime/Error.hs | 2 +- src/Cooked/Skeleton/Option.hs | 2 +- src/Cooked/UtxoSearch.hs | 2 +- 14 files changed, 15 insertions(+), 15 deletions(-) rename src/Cooked/{Common.hs => Aliases.hs} (94%) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 3063201d8..111f3e443 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -13,6 +13,7 @@ build-type: Simple library exposed-modules: Cooked + Cooked.Aliases Cooked.Attack Cooked.Attack.DatumHijacking Cooked.Attack.DatumTampering @@ -39,7 +40,6 @@ library Cooked.Automation.GenerateTx.ReferenceInputs Cooked.Automation.GenerateTx.Withdrawals Cooked.Automation.GenerateTx.Witness - Cooked.Common Cooked.Effect.Log Cooked.Effect.Misc Cooked.Effect.Read.Chain diff --git a/src/Cooked.hs b/src/Cooked.hs index aa6d4c757..d6055ac65 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -2,9 +2,9 @@ -- writing large test-suites. module Cooked (module X) where +import Cooked.Aliases as X import Cooked.Attack as X import Cooked.Automation as X -import Cooked.Common as X import Cooked.Effect.Misc as X import Cooked.Effect.Read.Chain as X import Cooked.Effect.Read.Conf as X diff --git a/src/Cooked/Common.hs b/src/Cooked/Aliases.hs similarity index 94% rename from src/Cooked/Common.hs rename to src/Cooked/Aliases.hs index d1539aaae..dfd77222b 100644 --- a/src/Cooked/Common.hs +++ b/src/Cooked/Aliases.hs @@ -1,5 +1,5 @@ --- | This module exposes some type aliases common to our MockChain library -module Cooked.Common +-- | This module exposes some type aliases common to our library +module Cooked.Aliases ( -- * Type aliases Fee, CollateralIns, diff --git a/src/Cooked/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs index f160b5c85..e5e5fb8aa 100644 --- a/src/Cooked/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -14,10 +14,10 @@ import Cardano.Api.Ledger qualified as Cardano import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway import Control.Monad +import Cooked.Aliases import Cooked.Automation.AutoFilling.MinAda import Cooked.Automation.GenerateTx.Body import Cooked.Automation.GenerateTx.Output -import Cooked.Common import Cooked.Effect.Log import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf diff --git a/src/Cooked/Automation/GenerateTx/Body.hs b/src/Cooked/Automation/GenerateTx/Body.hs index ca86e1184..770bc0ba9 100644 --- a/src/Cooked/Automation/GenerateTx/Body.hs +++ b/src/Cooked/Automation/GenerateTx/Body.hs @@ -12,6 +12,7 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Monad +import Cooked.Aliases import Cooked.Automation.GenerateTx.Certificate import Cooked.Automation.GenerateTx.Collateral import Cooked.Automation.GenerateTx.Input @@ -21,7 +22,6 @@ import Cooked.Automation.GenerateTx.Proposal import Cooked.Automation.GenerateTx.ReferenceInputs import Cooked.Automation.GenerateTx.Withdrawals import Cooked.Automation.GenerateTx.Witness -import Cooked.Common import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf import Cooked.Runtime.Error diff --git a/src/Cooked/Automation/GenerateTx/Collateral.hs b/src/Cooked/Automation/GenerateTx/Collateral.hs index 31b7d60a9..095d6bfde 100644 --- a/src/Cooked/Automation/GenerateTx/Collateral.hs +++ b/src/Cooked/Automation/GenerateTx/Collateral.hs @@ -6,8 +6,8 @@ module Cooked.Automation.GenerateTx.Collateral where import Cardano.Api qualified as Cardano +import Cooked.Aliases import Cooked.Automation.GenerateTx.Output -import Cooked.Common import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf import Cooked.Skeleton.Output diff --git a/src/Cooked/Effect/Log.hs b/src/Cooked/Effect/Log.hs index 991dcfdc3..30a7aa150 100644 --- a/src/Cooked/Effect/Log.hs +++ b/src/Cooked/Effect/Log.hs @@ -20,7 +20,7 @@ module Cooked.Effect.Log ) where -import Cooked.Common +import Cooked.Aliases import Cooked.Skeleton import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api diff --git a/src/Cooked/Effect/Read/Chain.hs b/src/Cooked/Effect/Read/Chain.hs index 01c60b891..30de71db3 100644 --- a/src/Cooked/Effect/Read/Chain.hs +++ b/src/Cooked/Effect/Read/Chain.hs @@ -40,8 +40,8 @@ import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano hiding (TxIn) import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad +import Cooked.Aliases import Cooked.Automation.GenerateTx.Credential -import Cooked.Common import Cooked.Effect.Read.Conf import Cooked.Runtime.Error import Cooked.Runtime.State diff --git a/src/Cooked/Effect/Submission.hs b/src/Cooked/Effect/Submission.hs index 8274eb6a4..12f6a3527 100644 --- a/src/Cooked/Effect/Submission.hs +++ b/src/Cooked/Effect/Submission.hs @@ -16,7 +16,7 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Shelley.API.Mempool qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Cooked.Common +import Cooked.Aliases import Cooked.Effect.Read.Conf import Cooked.Runtime.State import Data.Foldable.Extra diff --git a/src/Cooked/Effect/Validation.hs b/src/Cooked/Effect/Validation.hs index ab2c8731b..578b042b3 100644 --- a/src/Cooked/Effect/Validation.hs +++ b/src/Cooked/Effect/Validation.hs @@ -20,8 +20,8 @@ where import Cardano.Api qualified as Cardano import Control.Monad +import Cooked.Aliases import Cooked.Automation -import Cooked.Common import Cooked.Effect.Log import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf diff --git a/src/Cooked/Effect/Write.hs b/src/Cooked/Effect/Write.hs index ab90459eb..5aab16925 100644 --- a/src/Cooked/Effect/Write.hs +++ b/src/Cooked/Effect/Write.hs @@ -20,10 +20,10 @@ 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.Aliases import Cooked.Automation.AutoFilling.MinAda import Cooked.Automation.GenerateTx.Body import Cooked.Automation.GenerateTx.Output -import Cooked.Common import Cooked.Effect.Log import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf diff --git a/src/Cooked/Runtime/Error.hs b/src/Cooked/Runtime/Error.hs index 6857d6aa9..0d9eaf4ec 100644 --- a/src/Cooked/Runtime/Error.hs +++ b/src/Cooked/Runtime/Error.hs @@ -9,7 +9,7 @@ module Cooked.Runtime.Error ) where -import Cooked.Common +import Cooked.Aliases import Cooked.Skeleton.User import Ledger.Tx qualified as P.Ledger import PlutusLedgerApi.V3 qualified as Api diff --git a/src/Cooked/Skeleton/Option.hs b/src/Cooked/Skeleton/Option.hs index ae164eef5..6a49569d0 100644 --- a/src/Cooked/Skeleton/Option.hs +++ b/src/Cooked/Skeleton/Option.hs @@ -29,7 +29,7 @@ module Cooked.Skeleton.Option ) where -import Cooked.Common +import Cooked.Aliases import Data.Default import Data.Set (Set) import Data.Typeable diff --git a/src/Cooked/UtxoSearch.hs b/src/Cooked/UtxoSearch.hs index d2a583f98..5f88006bb 100644 --- a/src/Cooked/UtxoSearch.hs +++ b/src/Cooked/UtxoSearch.hs @@ -44,7 +44,7 @@ module Cooked.UtxoSearch where import Control.Monad (foldM) -import Cooked.Common +import Cooked.Aliases import Cooked.Effect.Read.Chain import Cooked.Families hiding (Member) import Cooked.Skeleton.Datum From e2cf199b0449fb94183ffd5e08599190e3204694 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 16:36:10 +0200 Subject: [PATCH 25/39] refactor(mockchain): move Testing into the Run subtree Move src/Cooked/Testing.hs to src/Cooked/Run/Testing.hs and rename the module Cooked.Testing to Cooked.Run.Testing. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 2 +- src/Cooked.hs | 2 +- src/Cooked/Pretty.hs | 2 +- src/Cooked/{ => Run}/Testing.hs | 2 +- tests/Spec/Ltl.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) rename src/Cooked/{ => Run}/Testing.hs (99%) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 111f3e443..690752680 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -59,6 +59,7 @@ library Cooked.Pretty.Skeleton Cooked.Run.Instances Cooked.Run.Runnable + Cooked.Run.Testing Cooked.Run.Tweak Cooked.Runtime.Error Cooked.Runtime.Journal @@ -79,7 +80,6 @@ library Cooked.Skeleton.ValidityRange Cooked.Skeleton.Value Cooked.Skeleton.Withdrawal - Cooked.Testing Cooked.Tweak Cooked.Tweak.Common Cooked.Tweak.Guard diff --git a/src/Cooked.hs b/src/Cooked.hs index d6055ac65..c9286c487 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -16,13 +16,13 @@ import Cooked.Ltl as X import Cooked.Pretty as X import Cooked.Run.Instances as X import Cooked.Run.Runnable as X +import Cooked.Run.Testing as X import Cooked.Run.Tweak as X import Cooked.Runtime.Error as X import Cooked.Runtime.Journal as X import Cooked.Runtime.State as X import Cooked.ShowBS as X import Cooked.Skeleton as X -import Cooked.Testing as X import Cooked.Tweak as X import Cooked.UtxoSearch as X import Cooked.Wallet as X diff --git a/src/Cooked/Pretty.hs b/src/Cooked/Pretty.hs index 9e5d2a913..b35b2d067 100644 --- a/src/Cooked/Pretty.hs +++ b/src/Cooked/Pretty.hs @@ -39,7 +39,7 @@ -- -- Pretty printing of transaction skeletons and UTxO states is done -- automatically by the end-user functions provided in --- "Cooked.Testing". +-- "Cooked.Run.Testing". -- -- To do it manually, use instances of 'PrettyCooked', 'PrettyCookedList' or -- 'PrettyCookedMaybe' defined in 'Cooked.Pretty.Skeleton' or diff --git a/src/Cooked/Testing.hs b/src/Cooked/Run/Testing.hs similarity index 99% rename from src/Cooked/Testing.hs rename to src/Cooked/Run/Testing.hs index 9538a9ec7..cb0b6b7c2 100644 --- a/src/Cooked/Testing.hs +++ b/src/Cooked/Run/Testing.hs @@ -2,7 +2,7 @@ -- | This modules provides primitives to run tests over mockchain executions and -- to provide requirements on the the number and results of these runs. -module Cooked.Testing +module Cooked.Run.Testing ( -- * Common interface between HUnit and QuickCheck IsProp (..), testBool, diff --git a/tests/Spec/Ltl.hs b/tests/Spec/Ltl.hs index 0b4dd03c1..0ab9616a1 100644 --- a/tests/Spec/Ltl.hs +++ b/tests/Spec/Ltl.hs @@ -4,7 +4,7 @@ module Spec.Ltl where import Control.Monad (MonadPlus (..), guard, replicateM, void) import Cooked.Ltl -import Cooked.Testing +import Cooked.Run.Testing import Data.Maybe import Polysemy import Polysemy.NonDet From 06d9fb9dfd48e63e118b5b69246e508ac7244ac4 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 16:45:35 +0200 Subject: [PATCH 26/39] refactor(mockchain): merge UtxoSearch into Effect.Read.Chain Fold the contents of Cooked.UtxoSearch into Cooked.Effect.Read.Chain and delete the now-empty UtxoSearch module. The UTxO search DSL naturally belongs with the chain-reading effect it is built upon. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 1 - src/Cooked.hs | 1 - .../AutoFilling/ReferenceScripts.hs | 1 - src/Cooked/Automation/Balancing.hs | 1 - src/Cooked/Effect/Read/Chain.hs | 245 ++++++++++++++++- src/Cooked/UtxoSearch.hs | 260 ------------------ 6 files changed, 244 insertions(+), 265 deletions(-) delete mode 100644 src/Cooked/UtxoSearch.hs diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 690752680..d3d42423a 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -88,7 +88,6 @@ library Cooked.Tweak.Query Cooked.Tweak.Remove Cooked.Tweak.Update - Cooked.UtxoSearch Cooked.Wallet other-modules: Paths_cooked_validators diff --git a/src/Cooked.hs b/src/Cooked.hs index c9286c487..a5eb8fe97 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -24,5 +24,4 @@ import Cooked.Runtime.State as X import Cooked.ShowBS as X import Cooked.Skeleton as X import Cooked.Tweak as X -import Cooked.UtxoSearch as X import Cooked.Wallet as X diff --git a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs index a71e8d9b3..e8ea8ce2f 100644 --- a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs +++ b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs @@ -14,7 +14,6 @@ import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Query import Cooked.Tweak.Update -import Cooked.UtxoSearch import Data.List (find) import Data.Map qualified as Map import Data.Set qualified as Set diff --git a/src/Cooked/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs index e5e5fb8aa..694df0a0e 100644 --- a/src/Cooked/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -23,7 +23,6 @@ import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf import Cooked.Runtime.Error import Cooked.Skeleton -import Cooked.UtxoSearch import Data.ByteString qualified as BS import Data.Foldable.Extra import Data.Map qualified as Map diff --git a/src/Cooked/Effect/Read/Chain.hs b/src/Cooked/Effect/Read/Chain.hs index 30de71db3..78ca922e2 100644 --- a/src/Cooked/Effect/Read/Chain.hs +++ b/src/Cooked/Effect/Read/Chain.hs @@ -1,6 +1,8 @@ -- | This module exposes the user-facing primitives to query the current state -- of the blockchain, such as the available UTxOs, and the current constitution --- or rewards. Time-related queries live in the separate +-- or rewards. It also provides the 'UtxoSearch' framework, a convenient way to +-- look through UTxOs, filter them, and extract pieces of information from them. +-- Time-related queries live in the separate -- 'Cooked.Effect.Time.MockChainTime' effect. The lower-level -- configuration primitives (protocol parameters, network id, era history, system -- start) live in the internal @@ -33,6 +35,45 @@ module Cooked.Effect.Read.Chain -- * Query fetching the current full constitution script getConstitutionScript, + + -- * UTxO searches + UtxoSearch, + beginSearch, + beginSearchPure, + + -- * Processing search result + RefinedOutputsList, + UtxoSearchResult, + utxosSearchResultUtxosI, + getUtxos, + getOutputsAndExtracts, + getExtracts, + getTxOutRefs, + + -- * Basic UTxO searches + utxosAtSearch, + allUtxosSearch, + txSkelOutByRefSearch, + txSkelOutByRefSearch', + + -- * Extracting new information from UTxOs + extract, + extractPure, + extractAFold, + extractTotal, + extractPureTotal, + extractGetter, + + -- * Filtering some UTxOs out + ensure, + ensurePure, + ensureAFoldIs, + ensureAFoldIsn't, + + -- * Cooked filters + ensureOnlyValueOutputs, + ensureVanillaOutputs, + ensureProperReferenceScript, ) where @@ -43,6 +84,7 @@ import Control.Monad import Cooked.Aliases import Cooked.Automation.GenerateTx.Credential import Cooked.Effect.Read.Conf +import Cooked.Families hiding (Member) import Cooked.Runtime.Error import Cooked.Runtime.State import Cooked.Skeleton @@ -52,11 +94,13 @@ import Data.Map qualified as Map import Data.Map.Optics (toMapOf) import Data.Maybe import Data.Maybe.Strict +import Data.Set (Set) import Data.Set qualified as Set import Ledger.Address qualified as P.Ledger import Ledger.Tx qualified as P.Ledger import Ledger.Tx.CardanoAPI qualified as P.Ledger 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 @@ -64,6 +108,7 @@ import Polysemy import Polysemy.Error import Polysemy.Reader import Polysemy.State +import Witherable (filterA, witherM) -- | 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 @@ -350,3 +395,201 @@ runBlockChainReadChain = interpret $ \case (P.Ledger.fromCardanoValue $ P.Ledger.fromCardanoTxOutValue val) False (P.Ledger.fromCardanoReferenceScript refScript) + +-- | 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, +-- alongside an heterogeneous list starting with the output in question, +-- followed by any element that was extracted during the search. +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 +-- output. The idea is to begin with a simple search and refine the search with +-- filters while appending new elements to the list. +type UtxoSearch effs elems = Sem effs (UtxoSearchResult elems) + +-- | Wraps up a computation returning a `Utxos` into a `UtxoSearch` +beginSearch :: + Sem effs Utxos -> + UtxoSearch effs '[] +beginSearch = fmap $ review utxosSearchResultUtxosI + +-- | Same as `beginSearch` with a pure input +beginSearchPure :: + Utxos -> + UtxoSearch effs '[] +beginSearchPure = beginSearch . return + +-- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` +getUtxos :: + Sem effs (UtxoSearchResult elems) -> + 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 [RefinedOutputsList elems] +getOutputsAndExtracts = fmap Map.elems + +-- | Retrieves the extracted elements from a `UtxoSearchResult` +getExtracts :: + Sem effs (UtxoSearchResult elems) -> + Sem effs [HList elems] +getExtracts = fmap (Map.elems . fmap hTail) + +-- | Retrieves the `Api.TxOutRef`s from a `UtxoSearchResult` +getTxOutRefs :: + Sem effs (UtxoSearchResult elems) -> + Sem effs (Set Api.TxOutRef) +getTxOutRefs = fmap Map.keysSet + +-- | Searches for utxos at a given address with a given filter +utxosAtSearch :: + (Member MockChainReadChain effs, Script.ToAddress pkh) => + pkh -> + (UtxoSearch effs '[] -> UtxoSearch effs els) -> + UtxoSearch effs els +utxosAtSearch pkh filters = filters $ beginSearch $ utxosAt pkh + +-- | Searches for all the known utxos with a given filter +allUtxosSearch :: + (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 MockChainReadChain effs) => + Set Api.TxOutRef -> + (UtxoSearch effs '[] -> UtxoSearch effs els) -> + UtxoSearch effs els +txSkelOutByRefSearch utxos filters = + 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) => + Set Api.TxOutRef -> + UtxoSearch effs '[] +txSkelOutByRefSearch' = (`txSkelOutByRefSearch` id) + +-- | 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 = + (>>= witherM (\(HCons txSkelOut es) -> fmap (HCons txSkelOut . (`HCons` es)) <$> extractFun txSkelOut)) + +-- | Same as `extract`, but with a pure extraction function +extractPure :: + (TxSkelOut -> Maybe b) -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractPure = extract . (return .) + +-- | Same as `extractPure`, using an affine fold to extract the element +extractAFold :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractAFold = extractPure . preview + +-- | Same as `extract`, but with a total extraction function +extractTotal :: + (TxSkelOut -> Sem effs b) -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractTotal = extract . (fmap Just .) + +-- | Same as `extract`, but with a pure and total extraction function +extractPureTotal :: + (TxSkelOut -> b) -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractPureTotal = extractTotal . (return .) + +-- | Same as `extractPureTotal`, using a getter to extract the element +extractGetter :: + (Is k A_Getter) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs (b ': els) +extractGetter = extractPureTotal . view + +-- | Ensures the outputs resulting from the search satisfy the given predicate +ensure :: + (TxSkelOut -> Sem effs Bool) -> + UtxoSearch effs els -> + UtxoSearch effs els +ensure filterF comp = + comp >>= filterA (filterF . hHead) + +-- | Same as `ensure`, but with a pure predicate +ensurePure :: + (TxSkelOut -> Bool) -> + UtxoSearch effs els -> + UtxoSearch effs els +ensurePure = ensure . (return .) + +-- | Ensures the outputs resulting from the search contain the focus of the +-- given affine fold +ensureAFoldIs :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs els +ensureAFoldIs = ensurePure . is + +-- | Ensures the outputs resulting from the search do not contain the focus of +-- the given affine fold +ensureAFoldIsn't :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearch effs els -> + UtxoSearch effs els +ensureAFoldIsn't = ensurePure . isn't + +-- | Ensures the outputs resulting from the search do not have a reference +-- script, nor a staking credential, nor a datum +ensureOnlyValueOutputs :: + UtxoSearch effs els -> + UtxoSearch effs els +ensureOnlyValueOutputs = + ensureAFoldIsn't txSkelOutReferenceScriptAT + . ensureAFoldIsn't txSkelOutStakingCredentialAT + . ensureAFoldIsn't (txSkelOutDatumL % txSkelOutDatumKindAT) + +-- | Same as 'ensureOnlyValueOutputs', but also ensures the searched outputs do not +-- contain non-ADA assets. +ensureVanillaOutputs :: + UtxoSearch effs els -> + UtxoSearch effs els +ensureVanillaOutputs = + ensureAFoldIs (txSkelOutValueL % valueLovelaceP) + . ensureOnlyValueOutputs + +-- | Ensures the outputs resulting from the search have the given script as a +-- reference script +ensureProperReferenceScript :: + (Script.ToScriptHash s) => + s -> + UtxoSearch effs els -> + UtxoSearch effs els +ensureProperReferenceScript (Script.toScriptHash -> sHash) = + ensureAFoldIs (txSkelOutReferenceScriptHashAF % filtered (== sHash)) diff --git a/src/Cooked/UtxoSearch.hs b/src/Cooked/UtxoSearch.hs deleted file mode 100644 index 5f88006bb..000000000 --- a/src/Cooked/UtxoSearch.hs +++ /dev/null @@ -1,260 +0,0 @@ --- | This module provides a convenient framework to look through UTxOs and: --- - filter them in a convenient manner --- - extract pieces of information from them -module Cooked.UtxoSearch - ( -- * UTxO searches - UtxoSearch, - beginSearch, - beginSearchPure, - - -- * Processing search result - RefinedOutputsList, - UtxoSearchResult, - utxosSearchResultUtxosI, - getUtxos, - getOutputsAndExtracts, - getExtracts, - getTxOutRefs, - - -- * Basic UTxO searches - utxosAtSearch, - allUtxosSearch, - txSkelOutByRefSearch, - txSkelOutByRefSearch', - - -- * Extracting new information from UTxOs - extract, - extractPure, - extractAFold, - extractTotal, - extractPureTotal, - extractGetter, - - -- * Filtering some UTxOs out - ensure, - ensurePure, - ensureAFoldIs, - ensureAFoldIsn't, - - -- * Cooked filters - ensureOnlyValueOutputs, - ensureVanillaOutputs, - ensureProperReferenceScript, - ) -where - -import Control.Monad (foldM) -import Cooked.Aliases -import Cooked.Effect.Read.Chain -import Cooked.Families hiding (Member) -import Cooked.Skeleton.Datum -import Cooked.Skeleton.Output -import Cooked.Skeleton.Value -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 - --- | 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, --- alongside an heterogeneous list starting with the output in question, --- followed by any element that was extracted during the search. -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 --- output. The idea is to begin with a simple search and refine the search with --- filters while appending new elements to the list. -type UtxoSearch effs elems = Sem effs (UtxoSearchResult elems) - --- | Wraps up a computation returning a `Utxos` into a `UtxoSearch` -beginSearch :: - Sem effs Utxos -> - UtxoSearch effs '[] -beginSearch = fmap $ review utxosSearchResultUtxosI - --- | Same as `beginSearch` with a pure input -beginSearchPure :: - Utxos -> - UtxoSearch effs '[] -beginSearchPure = beginSearch . return - --- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` -getUtxos :: - Sem effs (UtxoSearchResult elems) -> - 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 [RefinedOutputsList elems] -getOutputsAndExtracts = fmap Map.elems - --- | Retrieves the extracted elements from a `UtxoSearchResult` -getExtracts :: - Sem effs (UtxoSearchResult elems) -> - Sem effs [HList elems] -getExtracts = fmap (Map.elems . fmap hTail) - --- | Retrieves the `Api.TxOutRef`s from a `UtxoSearchResult` -getTxOutRefs :: - Sem effs (UtxoSearchResult elems) -> - Sem effs (Set Api.TxOutRef) -getTxOutRefs = fmap Map.keysSet - --- | Searches for utxos at a given address with a given filter -utxosAtSearch :: - (Member MockChainReadChain effs, Script.ToAddress pkh) => - pkh -> - (UtxoSearch effs '[] -> UtxoSearch effs els) -> - UtxoSearch effs els -utxosAtSearch pkh filters = filters $ beginSearch $ utxosAt pkh - --- | Searches for all the known utxos with a given filter -allUtxosSearch :: - (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 MockChainReadChain effs) => - Set Api.TxOutRef -> - (UtxoSearch effs '[] -> UtxoSearch effs els) -> - UtxoSearch effs els -txSkelOutByRefSearch utxos filters = - 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) => - Set Api.TxOutRef -> - UtxoSearch effs '[] -txSkelOutByRefSearch' = (`txSkelOutByRefSearch` id) - --- | 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 = - (>>= witherM (\(HCons txSkelOut es) -> fmap (HCons txSkelOut . (`HCons` es)) <$> extractFun txSkelOut)) - --- | Same as `extract`, but with a pure extraction function -extractPure :: - (TxSkelOut -> Maybe b) -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractPure = extract . (return .) - --- | Same as `extractPure`, using an affine fold to extract the element -extractAFold :: - (Is k An_AffineFold) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractAFold = extractPure . preview - --- | Same as `extract`, but with a total extraction function -extractTotal :: - (TxSkelOut -> Sem effs b) -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractTotal = extract . (fmap Just .) - --- | Same as `extract`, but with a pure and total extraction function -extractPureTotal :: - (TxSkelOut -> b) -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractPureTotal = extractTotal . (return .) - --- | Same as `extractPureTotal`, using a getter to extract the element -extractGetter :: - (Is k A_Getter) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractGetter = extractPureTotal . view - --- | Ensures the outputs resulting from the search satisfy the given predicate -ensure :: - (TxSkelOut -> Sem effs Bool) -> - UtxoSearch effs els -> - UtxoSearch effs els -ensure filterF comp = - comp >>= filterA (filterF . hHead) - --- | Same as `ensure`, but with a pure predicate -ensurePure :: - (TxSkelOut -> Bool) -> - UtxoSearch effs els -> - UtxoSearch effs els -ensurePure = ensure . (return .) - --- | Ensures the outputs resulting from the search contain the focus of the --- given affine fold -ensureAFoldIs :: - (Is k An_AffineFold) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs els -ensureAFoldIs = ensurePure . is - --- | Ensures the outputs resulting from the search do not contain the focus of --- the given affine fold -ensureAFoldIsn't :: - (Is k An_AffineFold) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs els -ensureAFoldIsn't = ensurePure . isn't - --- | Ensures the outputs resulting from the search do not have a reference --- script, nor a staking credential, nor a datum -ensureOnlyValueOutputs :: - UtxoSearch effs els -> - UtxoSearch effs els -ensureOnlyValueOutputs = - ensureAFoldIsn't txSkelOutReferenceScriptAT - . ensureAFoldIsn't txSkelOutStakingCredentialAT - . ensureAFoldIsn't (txSkelOutDatumL % txSkelOutDatumKindAT) - --- | Same as 'ensureOnlyValueOutputs', but also ensures the searched outputs do not --- contain non-ADA assets. -ensureVanillaOutputs :: - UtxoSearch effs els -> - UtxoSearch effs els -ensureVanillaOutputs = - ensureAFoldIs (txSkelOutValueL % valueLovelaceP) - . ensureOnlyValueOutputs - --- | Ensures the outputs resulting from the search have the given script as a --- reference script -ensureProperReferenceScript :: - (Script.ToScriptHash s) => - s -> - UtxoSearch effs els -> - UtxoSearch effs els -ensureProperReferenceScript (Script.toScriptHash -> sHash) = - ensureAFoldIs (txSkelOutReferenceScriptHashAF % filtered (== sHash)) From 07790f4ee9de706041ff7eba8a6a057d6acbc148 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 16:53:28 +0200 Subject: [PATCH 27/39] refactor(mockchain): rename the Run subtree to MockChain Rename src/Cooked/Run/ to src/Cooked/MockChain/ and the Cooked.Run.* modules (Instances, Runnable, Tweak, Testing) to Cooked.MockChain.*, so the MockChain namespace now holds only the emulated-blockchain-specific running code. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 8 ++++---- src/Cooked.hs | 8 ++++---- src/Cooked/{Run => MockChain}/Instances.hs | 6 +++--- src/Cooked/{Run => MockChain}/Runnable.hs | 2 +- src/Cooked/{Run => MockChain}/Testing.hs | 4 ++-- src/Cooked/{Run => MockChain}/Tweak.hs | 2 +- src/Cooked/Pretty.hs | 2 +- src/Cooked/Pretty/MockChain.hs | 2 +- tests/Spec/Ltl.hs | 2 +- 9 files changed, 18 insertions(+), 18 deletions(-) rename src/Cooked/{Run => MockChain}/Instances.hs (98%) rename src/Cooked/{Run => MockChain}/Runnable.hs (99%) rename src/Cooked/{Run => MockChain}/Testing.hs (99%) rename src/Cooked/{Run => MockChain}/Tweak.hs (99%) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index d3d42423a..3f5ff26b8 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -50,6 +50,10 @@ library Cooked.Effect.Write Cooked.Families Cooked.Ltl + Cooked.MockChain.Instances + Cooked.MockChain.Runnable + Cooked.MockChain.Testing + Cooked.MockChain.Tweak Cooked.Pretty Cooked.Pretty.Class Cooked.Pretty.Hashable @@ -57,10 +61,6 @@ library Cooked.Pretty.Options Cooked.Pretty.Plutus Cooked.Pretty.Skeleton - Cooked.Run.Instances - Cooked.Run.Runnable - Cooked.Run.Testing - Cooked.Run.Tweak Cooked.Runtime.Error Cooked.Runtime.Journal Cooked.Runtime.State diff --git a/src/Cooked.hs b/src/Cooked.hs index a5eb8fe97..132880edb 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -13,11 +13,11 @@ import Cooked.Effect.Validation as X import Cooked.Effect.Write as X import Cooked.Families as X import Cooked.Ltl as X +import Cooked.MockChain.Instances as X +import Cooked.MockChain.Runnable as X +import Cooked.MockChain.Testing as X +import Cooked.MockChain.Tweak as X import Cooked.Pretty as X -import Cooked.Run.Instances as X -import Cooked.Run.Runnable as X -import Cooked.Run.Testing as X -import Cooked.Run.Tweak as X import Cooked.Runtime.Error as X import Cooked.Runtime.Journal as X import Cooked.Runtime.State as X diff --git a/src/Cooked/Run/Instances.hs b/src/Cooked/MockChain/Instances.hs similarity index 98% rename from src/Cooked/Run/Instances.hs rename to src/Cooked/MockChain/Instances.hs index b1f74b566..1d607d87a 100644 --- a/src/Cooked/Run/Instances.hs +++ b/src/Cooked/MockChain/Instances.hs @@ -21,7 +21,7 @@ -- including intermediate hidden in the other instances. This should only be -- used when explicitly executing internal primitives of cooked, such as -- balancing, is required. -module Cooked.Run.Instances +module Cooked.MockChain.Instances ( -- * Direct, simple mockchain instance DirectEffs, DirectMockChain, @@ -56,8 +56,8 @@ import Cooked.Effect.Time import Cooked.Effect.Validation import Cooked.Effect.Write import Cooked.Ltl -import Cooked.Run.Runnable -import Cooked.Run.Tweak +import Cooked.MockChain.Runnable +import Cooked.MockChain.Tweak import Cooked.Runtime.Error import Cooked.Runtime.Journal import Cooked.Runtime.State diff --git a/src/Cooked/Run/Runnable.hs b/src/Cooked/MockChain/Runnable.hs similarity index 99% rename from src/Cooked/Run/Runnable.hs rename to src/Cooked/MockChain/Runnable.hs index e0fb61231..548f3e020 100644 --- a/src/Cooked/Run/Runnable.hs +++ b/src/Cooked/MockChain/Runnable.hs @@ -1,6 +1,6 @@ -- | This module exposes the infrastructure to execute mockchain and blockchain -- runs, in particular initial configurations, results, and running functions. -module Cooked.Run.Runnable +module Cooked.MockChain.Runnable ( -- * Initial distributions InitialDistribution, initialDistributionTemplate, diff --git a/src/Cooked/Run/Testing.hs b/src/Cooked/MockChain/Testing.hs similarity index 99% rename from src/Cooked/Run/Testing.hs rename to src/Cooked/MockChain/Testing.hs index cb0b6b7c2..5efe677ee 100644 --- a/src/Cooked/Run/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -2,7 +2,7 @@ -- | This modules provides primitives to run tests over mockchain executions and -- to provide requirements on the the number and results of these runs. -module Cooked.Run.Testing +module Cooked.MockChain.Testing ( -- * Common interface between HUnit and QuickCheck IsProp (..), testBool, @@ -90,8 +90,8 @@ import Control.Exception qualified as E import Control.Monad import Cooked.Effect.Log import Cooked.Effect.Write +import Cooked.MockChain.Runnable import Cooked.Pretty -import Cooked.Run.Runnable import Cooked.Runtime.Error import Cooked.Runtime.Journal import Cooked.Runtime.State diff --git a/src/Cooked/Run/Tweak.hs b/src/Cooked/MockChain/Tweak.hs similarity index 99% rename from src/Cooked/Run/Tweak.hs rename to src/Cooked/MockChain/Tweak.hs index 51662f749..365dad079 100644 --- a/src/Cooked/Run/Tweak.hs +++ b/src/Cooked/MockChain/Tweak.hs @@ -1,6 +1,6 @@ -- | This module applies the `Cooked.Tweak.Common.Tweak` effect for the purpose -- of modifying transaction skeleton before sending them for validation. -module Cooked.Run.Tweak +module Cooked.MockChain.Tweak ( -- * Modifying mockchain runs using tweaks reinterpretMockChainValidateWithTweak, diff --git a/src/Cooked/Pretty.hs b/src/Cooked/Pretty.hs index b35b2d067..8d05bd03d 100644 --- a/src/Cooked/Pretty.hs +++ b/src/Cooked/Pretty.hs @@ -39,7 +39,7 @@ -- -- Pretty printing of transaction skeletons and UTxO states is done -- automatically by the end-user functions provided in --- "Cooked.Run.Testing". +-- "Cooked.MockChain.Testing". -- -- To do it manually, use instances of 'PrettyCooked', 'PrettyCookedList' or -- 'PrettyCookedMaybe' defined in 'Cooked.Pretty.Skeleton' or diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index 31822704c..dfd9fe1ca 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -5,10 +5,10 @@ module Cooked.Pretty.MockChain () where import Cooked.Effect.Log +import Cooked.MockChain.Runnable import Cooked.Pretty.Class import Cooked.Pretty.Options import Cooked.Pretty.Skeleton -import Cooked.Run.Runnable import Cooked.Runtime.Error import Cooked.Runtime.Journal import Cooked.Runtime.State diff --git a/tests/Spec/Ltl.hs b/tests/Spec/Ltl.hs index 0ab9616a1..7aa73b9b6 100644 --- a/tests/Spec/Ltl.hs +++ b/tests/Spec/Ltl.hs @@ -4,7 +4,7 @@ module Spec.Ltl where import Control.Monad (MonadPlus (..), guard, replicateM, void) import Cooked.Ltl -import Cooked.Run.Testing +import Cooked.MockChain.Testing import Data.Maybe import Polysemy import Polysemy.NonDet From 412055b22d0647c679cd43edf107f2b348f36a9c Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 17:00:25 +0200 Subject: [PATCH 28/39] refactor(mockchain): add BlockChain module skeletons Introduce Cooked.BlockChain.Instances and Cooked.BlockChain.Runnable as the node-backend counterparts of the Cooked.MockChain running modules. They are currently empty placeholders. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 2 ++ src/Cooked/BlockChain/Instances.hs | 4 ++++ src/Cooked/BlockChain/Runnable.hs | 4 ++++ 3 files changed, 10 insertions(+) create mode 100644 src/Cooked/BlockChain/Instances.hs create mode 100644 src/Cooked/BlockChain/Runnable.hs diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 3f5ff26b8..79438792b 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -40,6 +40,8 @@ library Cooked.Automation.GenerateTx.ReferenceInputs Cooked.Automation.GenerateTx.Withdrawals Cooked.Automation.GenerateTx.Witness + Cooked.BlockChain.Instances + Cooked.BlockChain.Runnable Cooked.Effect.Log Cooked.Effect.Misc Cooked.Effect.Read.Chain diff --git a/src/Cooked/BlockChain/Instances.hs b/src/Cooked/BlockChain/Instances.hs new file mode 100644 index 000000000..4c7a450f3 --- /dev/null +++ b/src/Cooked/BlockChain/Instances.hs @@ -0,0 +1,4 @@ +-- | This module exposes the concrete instances to run a blockchain against a +-- real node backend, mirroring 'Cooked.MockChain.Instances' which targets the +-- emulated chain. +module Cooked.BlockChain.Instances () where diff --git a/src/Cooked/BlockChain/Runnable.hs b/src/Cooked/BlockChain/Runnable.hs new file mode 100644 index 000000000..9d338a51b --- /dev/null +++ b/src/Cooked/BlockChain/Runnable.hs @@ -0,0 +1,4 @@ +-- | This module exposes the infrastructure to execute blockchain runs against a +-- real node backend, mirroring 'Cooked.MockChain.Runnable' which targets the +-- emulated chain. +module Cooked.BlockChain.Runnable () where From fd609acf11ef09df944c089513294f70287e0f58 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 17:07:55 +0200 Subject: [PATCH 29/39] docs: use module-link syntax for the Cooked reference in Conf Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Cooked/Effect/Read/Conf.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Cooked/Effect/Read/Conf.hs b/src/Cooked/Effect/Read/Conf.hs index 3eed5bf19..23ac509a6 100644 --- a/src/Cooked/Effect/Read/Conf.hs +++ b/src/Cooked/Effect/Read/Conf.hs @@ -3,7 +3,7 @@ -- 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.Effect.Read.Chain.MockChainReadChain' effect, --- and they are deliberately not meant to be used directly through the 'Cooked' +-- and they are deliberately not meant to be used directly through the "Cooked" -- umbrella module. module Cooked.Effect.Read.Conf ( -- * The 'MockChainReadConf' effect From 35e14c65634ceeaa16e1a99b911d9df8d540564c Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 17:26:18 +0200 Subject: [PATCH 30/39] Add Effect, MockChain, Runtime and BlockChain umbrella modules Introduce one umbrella module per directory, following the existing umbrella convention, and make the top-level Cooked module re-export these umbrellas instead of the individual submodules. This also exposes the previously unexported Cooked.Effect.Log, Cooked.Effect.Submission and Cooked.BlockChain.* modules. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 4 ++++ src/Cooked.hs | 17 ++++------------- src/Cooked/BlockChain.hs | 7 +++++++ src/Cooked/Effect.hs | 14 ++++++++++++++ src/Cooked/MockChain.hs | 9 +++++++++ src/Cooked/Runtime.hs | 7 +++++++ 6 files changed, 45 insertions(+), 13 deletions(-) create mode 100644 src/Cooked/BlockChain.hs create mode 100644 src/Cooked/Effect.hs create mode 100644 src/Cooked/MockChain.hs create mode 100644 src/Cooked/Runtime.hs diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 79438792b..b131199cc 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -40,8 +40,10 @@ library Cooked.Automation.GenerateTx.ReferenceInputs Cooked.Automation.GenerateTx.Withdrawals Cooked.Automation.GenerateTx.Witness + Cooked.BlockChain Cooked.BlockChain.Instances Cooked.BlockChain.Runnable + Cooked.Effect Cooked.Effect.Log Cooked.Effect.Misc Cooked.Effect.Read.Chain @@ -52,6 +54,7 @@ library Cooked.Effect.Write Cooked.Families Cooked.Ltl + Cooked.MockChain Cooked.MockChain.Instances Cooked.MockChain.Runnable Cooked.MockChain.Testing @@ -63,6 +66,7 @@ library Cooked.Pretty.Options Cooked.Pretty.Plutus Cooked.Pretty.Skeleton + Cooked.Runtime Cooked.Runtime.Error Cooked.Runtime.Journal Cooked.Runtime.State diff --git a/src/Cooked.hs b/src/Cooked.hs index 132880edb..7a20c32d2 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -5,22 +5,13 @@ module Cooked (module X) where import Cooked.Aliases as X import Cooked.Attack as X import Cooked.Automation as X -import Cooked.Effect.Misc as X -import Cooked.Effect.Read.Chain as X -import Cooked.Effect.Read.Conf as X -import Cooked.Effect.Time as X -import Cooked.Effect.Validation as X -import Cooked.Effect.Write as X +import Cooked.BlockChain () +import Cooked.Effect as X import Cooked.Families as X import Cooked.Ltl as X -import Cooked.MockChain.Instances as X -import Cooked.MockChain.Runnable as X -import Cooked.MockChain.Testing as X -import Cooked.MockChain.Tweak as X +import Cooked.MockChain as X import Cooked.Pretty as X -import Cooked.Runtime.Error as X -import Cooked.Runtime.Journal as X -import Cooked.Runtime.State as X +import Cooked.Runtime as X import Cooked.ShowBS as X import Cooked.Skeleton as X import Cooked.Tweak as X diff --git a/src/Cooked/BlockChain.hs b/src/Cooked/BlockChain.hs new file mode 100644 index 000000000..b66df75d4 --- /dev/null +++ b/src/Cooked/BlockChain.hs @@ -0,0 +1,7 @@ +-- | This module centralizes the node-backend (BlockChain) running code. It is +-- an umbrella re-exporting all the BlockChain submodules, which only provide +-- instances. +module Cooked.BlockChain () where + +import Cooked.BlockChain.Instances () +import Cooked.BlockChain.Runnable () diff --git a/src/Cooked/Effect.hs b/src/Cooked/Effect.hs new file mode 100644 index 000000000..3ca6cce0c --- /dev/null +++ b/src/Cooked/Effect.hs @@ -0,0 +1,14 @@ +-- | This module centralizes the @polysemy@ effects that define the +-- capabilities of a chain (reading, writing, logging, submission, time, +-- validation and miscellaneous primitives). It is an umbrella re-exporting all +-- the effect submodules. +module Cooked.Effect (module X) where + +import Cooked.Effect.Log as X +import Cooked.Effect.Misc as X +import Cooked.Effect.Read.Chain as X +import Cooked.Effect.Read.Conf as X +import Cooked.Effect.Submission as X +import Cooked.Effect.Time as X +import Cooked.Effect.Validation as X +import Cooked.Effect.Write as X diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs new file mode 100644 index 000000000..dea3b6f4f --- /dev/null +++ b/src/Cooked/MockChain.hs @@ -0,0 +1,9 @@ +-- | This module centralizes the emulated-chain (MockChain) running code. It is +-- an umbrella re-exporting all the MockChain submodules (instances, running, +-- tweaking and testing). +module Cooked.MockChain (module X) where + +import Cooked.MockChain.Instances as X +import Cooked.MockChain.Runnable as X +import Cooked.MockChain.Testing as X +import Cooked.MockChain.Tweak as X diff --git a/src/Cooked/Runtime.hs b/src/Cooked/Runtime.hs new file mode 100644 index 000000000..d9406cf64 --- /dev/null +++ b/src/Cooked/Runtime.hs @@ -0,0 +1,7 @@ +-- | This module centralizes the running-state types of a chain run. It is an +-- umbrella re-exporting all the runtime submodules (errors, journal and state). +module Cooked.Runtime (module X) where + +import Cooked.Runtime.Error as X +import Cooked.Runtime.Journal as X +import Cooked.Runtime.State as X From bd4e2afb0c35a1a654012bc6d020cf309c8c185b Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 17:44:32 +0200 Subject: [PATCH 31/39] Add Utilities umbrella, move Ltl under MockChain, document umbrella convention Group the transverse utilities (Aliases, Families, Wallet, ShowBS) into a new Cooked.Utilities directory with a Cooked.Utilities umbrella module, and move Cooked.Ltl into Cooked.MockChain.Ltl (re-exported from the MockChain umbrella). The top-level Cooked module now re-exports these umbrellas. Document the umbrella-module organization convention in CONTRIBUTING.md. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- CONTRIBUTING.md | 46 +++++++++++++++++++ cooked-validators.cabal | 11 +++-- src/Cooked.hs | 6 +-- src/Cooked/Automation/Balancing.hs | 2 +- src/Cooked/Automation/GenerateTx/Body.hs | 2 +- .../Automation/GenerateTx/Collateral.hs | 2 +- src/Cooked/Effect/Log.hs | 2 +- src/Cooked/Effect/Read/Chain.hs | 4 +- src/Cooked/Effect/Submission.hs | 2 +- src/Cooked/Effect/Validation.hs | 2 +- src/Cooked/Effect/Write.hs | 2 +- src/Cooked/MockChain.hs | 1 + src/Cooked/MockChain/Instances.hs | 2 +- src/Cooked/{ => MockChain}/Ltl.hs | 2 +- src/Cooked/MockChain/Runnable.hs | 2 +- src/Cooked/MockChain/Tweak.hs | 2 +- src/Cooked/Pretty/Class.hs | 2 +- src/Cooked/Pretty/Hashable.hs | 2 +- src/Cooked/Pretty/MockChain.hs | 2 +- src/Cooked/Pretty/Options.hs | 2 +- src/Cooked/Pretty/Skeleton.hs | 2 +- src/Cooked/Runtime/Error.hs | 2 +- src/Cooked/Skeleton/Certificate.hs | 2 +- src/Cooked/Skeleton/Option.hs | 2 +- src/Cooked/Skeleton/Output.hs | 4 +- src/Cooked/Skeleton/Signatory.hs | 2 +- src/Cooked/Skeleton/User.hs | 2 +- src/Cooked/Tweak.hs | 2 +- src/Cooked/Utilities.hs | 9 ++++ src/Cooked/{ => Utilities}/Aliases.hs | 2 +- src/Cooked/{ => Utilities}/Families.hs | 2 +- src/Cooked/{ => Utilities}/ShowBS.hs | 2 +- src/Cooked/{ => Utilities}/Wallet.hs | 2 +- tests/Plutus/Withdrawals.hs | 2 +- tests/Spec/Ltl.hs | 2 +- 35 files changed, 95 insertions(+), 42 deletions(-) rename src/Cooked/{ => MockChain}/Ltl.hs (99%) create mode 100644 src/Cooked/Utilities.hs rename src/Cooked/{ => Utilities}/Aliases.hs (98%) rename src/Cooked/{ => Utilities}/Families.hs (99%) rename src/Cooked/{ => Utilities}/ShowBS.hs (99%) rename src/Cooked/{ => Utilities}/Wallet.hs (99%) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 89b30d2a8..6e903efce 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -164,6 +164,52 @@ When you are creating an enhancement request, follow these guidelines: - Document all your functions using [Haddock]'s syntax. +### Module organization (umbrella modules) + +Cohesive-but-multi-concern parts of the library are split into focused, +per-concern submodules that live in a directory, and re-exported from an +_umbrella module_ bearing the name of that directory (e.g. `Cooked.Tweak` +re-exports `Cooked.Tweak.Guard`, `Cooked.Tweak.Insert`, ...). Follow these +conventions when adding or reorganizing modules: + +- **One umbrella per directory.** When a directory groups several submodules + that form a coherent sub-system, add an umbrella module of the same name that + re-exports them all, typically as: + + ```haskell + -- | One-line description of the sub-system. + module Cooked.Foo (module X) where + + import Cooked.Foo.Bar as X + import Cooked.Foo.Baz as X + ``` + +- **Re-export instance-only submodules with `()`.** When a submodule only + provides instances (empty export list), import it in the umbrella as + `import Cooked.Foo.Bar ()` so its instances are brought in without polluting + the export list. If _all_ submodules are instance-only, the umbrella itself + has an empty export list (`module Cooked.Foo () where`). + +- **Umbrellas are aggregators first.** An umbrella may additionally host the + central type or entry point of its sub-system (as `Cooked.Skeleton` hosts + `TxSkel` and `Cooked.Automation` hosts `runAutomationPipeline`), but should + not accumulate unrelated logic. Everything else belongs in a submodule. + +- **Do not systematically nest umbrellas.** A sub-directory whose submodules are + a mere refinement of their parent sub-system may be flattened into the parent + umbrella rather than getting its own (e.g. `Cooked.Automation.GenerateTx.*` + and `Cooked.Effect.Read.*` are re-exported directly from `Cooked.Automation` + and `Cooked.Effect`). Add an intermediate umbrella only when the sub-directory + is itself an independently meaningful sub-system. + +- **Transverse utilities** (type aliases, wallets, low-level helpers) live under + `Cooked.Utilities.*` and are re-exported from `Cooked.Utilities`, keeping the + top level of `Cooked.*` for the functional pillars of the library. + +- The top-level `Cooked` module is the global umbrella: it re-exports the + per-directory umbrellas only, never individual submodules. Adding a new + sub-system therefore means adding a single import line there. + ### Nix style guide - All Nix code is formatted with [nixfmt]. diff --git a/cooked-validators.cabal b/cooked-validators.cabal index b131199cc..90ef0a62c 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -13,7 +13,6 @@ build-type: Simple library exposed-modules: Cooked - Cooked.Aliases Cooked.Attack Cooked.Attack.DatumHijacking Cooked.Attack.DatumTampering @@ -52,10 +51,9 @@ library Cooked.Effect.Time Cooked.Effect.Validation Cooked.Effect.Write - Cooked.Families - Cooked.Ltl Cooked.MockChain Cooked.MockChain.Instances + Cooked.MockChain.Ltl Cooked.MockChain.Runnable Cooked.MockChain.Testing Cooked.MockChain.Tweak @@ -70,7 +68,6 @@ library Cooked.Runtime.Error Cooked.Runtime.Journal Cooked.Runtime.State - Cooked.ShowBS Cooked.Skeleton Cooked.Skeleton.Anchor Cooked.Skeleton.Certificate @@ -94,7 +91,11 @@ library Cooked.Tweak.Query Cooked.Tweak.Remove Cooked.Tweak.Update - Cooked.Wallet + Cooked.Utilities + Cooked.Utilities.Aliases + Cooked.Utilities.Families + Cooked.Utilities.ShowBS + Cooked.Utilities.Wallet other-modules: Paths_cooked_validators autogen-modules: diff --git a/src/Cooked.hs b/src/Cooked.hs index 7a20c32d2..5abc8458d 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -2,17 +2,13 @@ -- writing large test-suites. module Cooked (module X) where -import Cooked.Aliases as X import Cooked.Attack as X import Cooked.Automation as X import Cooked.BlockChain () import Cooked.Effect as X -import Cooked.Families as X -import Cooked.Ltl as X import Cooked.MockChain as X import Cooked.Pretty as X import Cooked.Runtime as X -import Cooked.ShowBS as X import Cooked.Skeleton as X import Cooked.Tweak as X -import Cooked.Wallet as X +import Cooked.Utilities as X diff --git a/src/Cooked/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs index 694df0a0e..6563878ae 100644 --- a/src/Cooked/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -14,7 +14,6 @@ import Cardano.Api.Ledger qualified as Cardano import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Ledger.Conway.PParams qualified as Conway import Control.Monad -import Cooked.Aliases import Cooked.Automation.AutoFilling.MinAda import Cooked.Automation.GenerateTx.Body import Cooked.Automation.GenerateTx.Output @@ -23,6 +22,7 @@ import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf import Cooked.Runtime.Error import Cooked.Skeleton +import Cooked.Utilities.Aliases import Data.ByteString qualified as BS import Data.Foldable.Extra import Data.Map qualified as Map diff --git a/src/Cooked/Automation/GenerateTx/Body.hs b/src/Cooked/Automation/GenerateTx/Body.hs index 770bc0ba9..265015512 100644 --- a/src/Cooked/Automation/GenerateTx/Body.hs +++ b/src/Cooked/Automation/GenerateTx/Body.hs @@ -12,7 +12,6 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Monad -import Cooked.Aliases import Cooked.Automation.GenerateTx.Certificate import Cooked.Automation.GenerateTx.Collateral import Cooked.Automation.GenerateTx.Input @@ -26,6 +25,7 @@ import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf import Cooked.Runtime.Error import Cooked.Skeleton +import Cooked.Utilities.Aliases import Data.Bifunctor (first) import Data.Map qualified as Map import Data.Set qualified as Set diff --git a/src/Cooked/Automation/GenerateTx/Collateral.hs b/src/Cooked/Automation/GenerateTx/Collateral.hs index 095d6bfde..8359ad930 100644 --- a/src/Cooked/Automation/GenerateTx/Collateral.hs +++ b/src/Cooked/Automation/GenerateTx/Collateral.hs @@ -6,12 +6,12 @@ module Cooked.Automation.GenerateTx.Collateral where import Cardano.Api qualified as Cardano -import Cooked.Aliases import Cooked.Automation.GenerateTx.Output import Cooked.Effect.Read.Chain import Cooked.Effect.Read.Conf import Cooked.Skeleton.Output import Cooked.Skeleton.Value +import Cooked.Utilities.Aliases import Data.Map qualified as Map import Data.Set qualified as Set import Ledger.Tx.CardanoAPI qualified as P.Ledger diff --git a/src/Cooked/Effect/Log.hs b/src/Cooked/Effect/Log.hs index 30a7aa150..33717a76d 100644 --- a/src/Cooked/Effect/Log.hs +++ b/src/Cooked/Effect/Log.hs @@ -20,8 +20,8 @@ module Cooked.Effect.Log ) where -import Cooked.Aliases import Cooked.Skeleton +import Cooked.Utilities.Aliases import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api import Polysemy diff --git a/src/Cooked/Effect/Read/Chain.hs b/src/Cooked/Effect/Read/Chain.hs index 78ca922e2..da5983ef8 100644 --- a/src/Cooked/Effect/Read/Chain.hs +++ b/src/Cooked/Effect/Read/Chain.hs @@ -81,13 +81,13 @@ import Cardano.Api qualified as Cardano import Cardano.Api.Ledger qualified as Cardano hiding (TxIn) import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad -import Cooked.Aliases import Cooked.Automation.GenerateTx.Credential import Cooked.Effect.Read.Conf -import Cooked.Families hiding (Member) import Cooked.Runtime.Error import Cooked.Runtime.State import Cooked.Skeleton +import Cooked.Utilities.Aliases +import Cooked.Utilities.Families hiding (Member) import Data.Coerce (coerce) import Data.Map (Map) import Data.Map qualified as Map diff --git a/src/Cooked/Effect/Submission.hs b/src/Cooked/Effect/Submission.hs index 12f6a3527..eab1c19b8 100644 --- a/src/Cooked/Effect/Submission.hs +++ b/src/Cooked/Effect/Submission.hs @@ -16,9 +16,9 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Shelley.API.Mempool qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Cooked.Aliases import Cooked.Effect.Read.Conf import Cooked.Runtime.State +import Cooked.Utilities.Aliases import Data.Foldable.Extra import Ledger.Orphans () import Optics.Core diff --git a/src/Cooked/Effect/Validation.hs b/src/Cooked/Effect/Validation.hs index 578b042b3..95ce343de 100644 --- a/src/Cooked/Effect/Validation.hs +++ b/src/Cooked/Effect/Validation.hs @@ -20,7 +20,6 @@ where import Cardano.Api qualified as Cardano import Control.Monad -import Cooked.Aliases import Cooked.Automation import Cooked.Effect.Log import Cooked.Effect.Read.Chain @@ -29,6 +28,7 @@ import Cooked.Effect.Submission import Cooked.Runtime.Error import Cooked.Runtime.State import Cooked.Skeleton +import Cooked.Utilities.Aliases import Data.Foldable.Extra import Data.Map.Strict qualified as Map import Data.Set qualified as Set diff --git a/src/Cooked/Effect/Write.hs b/src/Cooked/Effect/Write.hs index 5aab16925..6ff252dbd 100644 --- a/src/Cooked/Effect/Write.hs +++ b/src/Cooked/Effect/Write.hs @@ -20,7 +20,6 @@ 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.Aliases import Cooked.Automation.AutoFilling.MinAda import Cooked.Automation.GenerateTx.Body import Cooked.Automation.GenerateTx.Output @@ -30,6 +29,7 @@ import Cooked.Effect.Read.Conf import Cooked.Runtime.Error import Cooked.Runtime.State import Cooked.Skeleton +import Cooked.Utilities.Aliases import Data.Map.Strict qualified as Map import Ledger.Index qualified as P.Ledger import Ledger.Orphans () diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index dea3b6f4f..54bd1c790 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -4,6 +4,7 @@ module Cooked.MockChain (module X) where import Cooked.MockChain.Instances as X +import Cooked.MockChain.Ltl as X import Cooked.MockChain.Runnable as X import Cooked.MockChain.Testing as X import Cooked.MockChain.Tweak as X diff --git a/src/Cooked/MockChain/Instances.hs b/src/Cooked/MockChain/Instances.hs index 1d607d87a..f7c8e36c6 100644 --- a/src/Cooked/MockChain/Instances.hs +++ b/src/Cooked/MockChain/Instances.hs @@ -55,7 +55,7 @@ import Cooked.Effect.Submission import Cooked.Effect.Time import Cooked.Effect.Validation import Cooked.Effect.Write -import Cooked.Ltl +import Cooked.MockChain.Ltl import Cooked.MockChain.Runnable import Cooked.MockChain.Tweak import Cooked.Runtime.Error diff --git a/src/Cooked/Ltl.hs b/src/Cooked/MockChain/Ltl.hs similarity index 99% rename from src/Cooked/Ltl.hs rename to src/Cooked/MockChain/Ltl.hs index 61637fa13..a8563088d 100644 --- a/src/Cooked/Ltl.hs +++ b/src/Cooked/MockChain/Ltl.hs @@ -3,7 +3,7 @@ -- | This modules provides the infrastructure to modify sequences of -- transactions using LTL formulaes with atomic modifications. This idea is to -- describe when to apply certain modifications within a trace. -module Cooked.Ltl +module Cooked.MockChain.Ltl ( -- * `Ltl` formulas Ltl (..), diff --git a/src/Cooked/MockChain/Runnable.hs b/src/Cooked/MockChain/Runnable.hs index 548f3e020..8f654b49c 100644 --- a/src/Cooked/MockChain/Runnable.hs +++ b/src/Cooked/MockChain/Runnable.hs @@ -30,7 +30,7 @@ import Cooked.Runtime.Error import Cooked.Runtime.Journal import Cooked.Runtime.State import Cooked.Skeleton.Output -import Cooked.Wallet +import Cooked.Utilities.Wallet import Data.Default import Data.List (foldl') import Data.Map (Map) diff --git a/src/Cooked/MockChain/Tweak.hs b/src/Cooked/MockChain/Tweak.hs index 365dad079..3c361db04 100644 --- a/src/Cooked/MockChain/Tweak.hs +++ b/src/Cooked/MockChain/Tweak.hs @@ -20,7 +20,7 @@ where import Control.Monad import Cooked.Effect.Validation -import Cooked.Ltl +import Cooked.MockChain.Ltl import Cooked.Tweak.Common import Polysemy import Polysemy.Internal diff --git a/src/Cooked/Pretty/Class.hs b/src/Cooked/Pretty/Class.hs index ab8d810d8..f148cb389 100644 --- a/src/Cooked/Pretty/Class.hs +++ b/src/Cooked/Pretty/Class.hs @@ -15,9 +15,9 @@ module Cooked.Pretty.Class ) where -import Cooked.Families import Cooked.Pretty.Hashable import Cooked.Pretty.Options +import Cooked.Utilities.Families import Data.ByteString qualified as ByteString import Data.Default import Data.Map qualified as Map diff --git a/src/Cooked/Pretty/Hashable.hs b/src/Cooked/Pretty/Hashable.hs index 898ff9892..1806e3aaf 100644 --- a/src/Cooked/Pretty/Hashable.hs +++ b/src/Cooked/Pretty/Hashable.hs @@ -6,7 +6,7 @@ module Cooked.Pretty.Hashable ) where -import Cooked.Wallet +import Cooked.Utilities.Wallet import Plutus.Script.Utils.Address qualified as Script import Plutus.Script.Utils.Data qualified as Script import Plutus.Script.Utils.Scripts qualified as Script diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index dfd9fe1ca..c91d448d5 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -13,7 +13,7 @@ import Cooked.Runtime.Error import Cooked.Runtime.Journal import Cooked.Runtime.State import Cooked.Skeleton.User -import Cooked.Wallet (walletPKHashToId) +import Cooked.Utilities.Wallet (walletPKHashToId) import Data.Function (on) import Data.List (intersperse) import Data.List qualified as List diff --git a/src/Cooked/Pretty/Options.hs b/src/Cooked/Pretty/Options.hs index 3f696a705..38a254836 100644 --- a/src/Cooked/Pretty/Options.hs +++ b/src/Cooked/Pretty/Options.hs @@ -11,7 +11,7 @@ module Cooked.Pretty.Options where import Cooked.Pretty.Hashable -import Cooked.Wallet +import Cooked.Utilities.Wallet import Data.Bifunctor (first) import Data.Default import Data.Map (Map) diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index cfd961a0b..aadd3f358 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/src/Cooked/Pretty/Skeleton.hs @@ -7,7 +7,7 @@ module Cooked.Pretty.Skeleton (Contextualized (..)) where import Cooked.Pretty.Class import Cooked.Pretty.Plutus () import Cooked.Skeleton -import Cooked.Wallet (Wallet) +import Cooked.Utilities.Wallet (Wallet) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes) diff --git a/src/Cooked/Runtime/Error.hs b/src/Cooked/Runtime/Error.hs index 0d9eaf4ec..0800d1b96 100644 --- a/src/Cooked/Runtime/Error.hs +++ b/src/Cooked/Runtime/Error.hs @@ -9,8 +9,8 @@ module Cooked.Runtime.Error ) where -import Cooked.Aliases import Cooked.Skeleton.User +import Cooked.Utilities.Aliases import Ledger.Tx qualified as P.Ledger import PlutusLedgerApi.V3 qualified as Api import Polysemy diff --git a/src/Cooked/Skeleton/Certificate.hs b/src/Cooked/Skeleton/Certificate.hs index e87a4a13b..b73c45c20 100644 --- a/src/Cooked/Skeleton/Certificate.hs +++ b/src/Cooked/Skeleton/Certificate.hs @@ -17,9 +17,9 @@ module Cooked.Skeleton.Certificate ) where -import Cooked.Families import Cooked.Skeleton.Redeemer import Cooked.Skeleton.User +import Cooked.Utilities.Families import Data.Kind (Type) import Data.Typeable (Typeable, cast) import Ledger.Slot qualified as P.Ledger diff --git a/src/Cooked/Skeleton/Option.hs b/src/Cooked/Skeleton/Option.hs index 6a49569d0..fc99f9608 100644 --- a/src/Cooked/Skeleton/Option.hs +++ b/src/Cooked/Skeleton/Option.hs @@ -29,7 +29,7 @@ module Cooked.Skeleton.Option ) where -import Cooked.Aliases +import Cooked.Utilities.Aliases import Data.Default import Data.Set (Set) import Data.Typeable diff --git a/src/Cooked/Skeleton/Output.hs b/src/Cooked/Skeleton/Output.hs index 99126706c..91cebdde4 100644 --- a/src/Cooked/Skeleton/Output.hs +++ b/src/Cooked/Skeleton/Output.hs @@ -30,11 +30,11 @@ module Cooked.Skeleton.Output ) where -import Cooked.Families import Cooked.Skeleton.Datum import Cooked.Skeleton.User import Cooked.Skeleton.Value () -import Cooked.Wallet +import Cooked.Utilities.Families +import Cooked.Utilities.Wallet import Data.Kind import Data.Typeable import Optics.Core diff --git a/src/Cooked/Skeleton/Signatory.hs b/src/Cooked/Skeleton/Signatory.hs index e3307651e..aa22e5fab 100644 --- a/src/Cooked/Skeleton/Signatory.hs +++ b/src/Cooked/Skeleton/Signatory.hs @@ -16,7 +16,7 @@ module Cooked.Skeleton.Signatory where import Cardano.Crypto.Wallet qualified as Crypto -import Cooked.Wallet +import Cooked.Utilities.Wallet import Optics.Core import Optics.TH import Plutus.Script.Utils.V3 qualified as Script diff --git a/src/Cooked/Skeleton/User.hs b/src/Cooked/Skeleton/User.hs index 1b8ce74dc..ec49993e9 100644 --- a/src/Cooked/Skeleton/User.hs +++ b/src/Cooked/Skeleton/User.hs @@ -37,8 +37,8 @@ module Cooked.Skeleton.User ) where -import Cooked.Families import Cooked.Skeleton.Redeemer +import Cooked.Utilities.Families import Data.Kind import Data.Typeable import Optics.Core diff --git a/src/Cooked/Tweak.hs b/src/Cooked/Tweak.hs index 916c4b384..7c7a083be 100644 --- a/src/Cooked/Tweak.hs +++ b/src/Cooked/Tweak.hs @@ -1,6 +1,6 @@ -- | This module centralizes Tweaks, that is state-aware skeleton -- modifications. These tweaks can be used on specific skeletons, or deployed in --- time using `Cooked.Ltl` +-- time using `Cooked.MockChain.Ltl` module Cooked.Tweak (module X) where import Cooked.Tweak.Common as X diff --git a/src/Cooked/Utilities.hs b/src/Cooked/Utilities.hs new file mode 100644 index 000000000..963f04f5b --- /dev/null +++ b/src/Cooked/Utilities.hs @@ -0,0 +1,9 @@ +-- | This module centralizes the transverse utilities used throughout the +-- library (common type aliases, type-family helpers, wallets and a Plutus-level +-- 'ShowBS'). It is an umbrella re-exporting all the utility submodules. +module Cooked.Utilities (module X) where + +import Cooked.Utilities.Aliases as X +import Cooked.Utilities.Families as X +import Cooked.Utilities.ShowBS as X +import Cooked.Utilities.Wallet as X diff --git a/src/Cooked/Aliases.hs b/src/Cooked/Utilities/Aliases.hs similarity index 98% rename from src/Cooked/Aliases.hs rename to src/Cooked/Utilities/Aliases.hs index dfd77222b..391eeede2 100644 --- a/src/Cooked/Aliases.hs +++ b/src/Cooked/Utilities/Aliases.hs @@ -1,5 +1,5 @@ -- | This module exposes some type aliases common to our library -module Cooked.Aliases +module Cooked.Utilities.Aliases ( -- * Type aliases Fee, CollateralIns, diff --git a/src/Cooked/Families.hs b/src/Cooked/Utilities/Families.hs similarity index 99% rename from src/Cooked/Families.hs rename to src/Cooked/Utilities/Families.hs index c8b562946..d416ee41b 100644 --- a/src/Cooked/Families.hs +++ b/src/Cooked/Utilities/Families.hs @@ -3,7 +3,7 @@ -- | This module exposes some type families used to either directly constraint -- values within our skeletons, or constraint inputs of smart constructors for -- components of these skeletons. -module Cooked.Families +module Cooked.Utilities.Families ( -- * Type-level constraints type (∈), type (∉), diff --git a/src/Cooked/ShowBS.hs b/src/Cooked/Utilities/ShowBS.hs similarity index 99% rename from src/Cooked/ShowBS.hs rename to src/Cooked/Utilities/ShowBS.hs index e5cd50844..88990e565 100644 --- a/src/Cooked/ShowBS.hs +++ b/src/Cooked/Utilities/ShowBS.hs @@ -10,7 +10,7 @@ -- module, consider using -- 'Cooked.Skeleton.Option.txOptEmulatorParamsModification' to temporarily -- loosen the limits (at the cost of breaking compatibility with mainnet) -module Cooked.ShowBS (ShowBS (..)) where +module Cooked.Utilities.ShowBS (ShowBS (..)) where import PlutusLedgerApi.V3 qualified as Api import PlutusTx.AssocMap qualified as Map diff --git a/src/Cooked/Wallet.hs b/src/Cooked/Utilities/Wallet.hs similarity index 99% rename from src/Cooked/Wallet.hs rename to src/Cooked/Utilities/Wallet.hs index e471f40f2..ff19cc3d6 100644 --- a/src/Cooked/Wallet.hs +++ b/src/Cooked/Utilities/Wallet.hs @@ -3,7 +3,7 @@ -- | This module defines convenient wrappers for mock chain wallets (around -- Plutus mock wallets) with an associate API to construct them, manipulate -- them, and fetch information (such as public/private and staking keys). -module Cooked.Wallet +module Cooked.Utilities.Wallet ( knownWallets, wallet, walletPKHashToId, diff --git a/tests/Plutus/Withdrawals.hs b/tests/Plutus/Withdrawals.hs index ccc2c95cd..cbe93d5e8 100644 --- a/tests/Plutus/Withdrawals.hs +++ b/tests/Plutus/Withdrawals.hs @@ -2,7 +2,7 @@ module Plutus.Withdrawals where -import Cooked.ShowBS +import Cooked.Utilities.ShowBS import Plutus.Script.Utils.V3 qualified as Script import PlutusLedgerApi.V3 qualified as Api import PlutusTx diff --git a/tests/Spec/Ltl.hs b/tests/Spec/Ltl.hs index 7aa73b9b6..af38ee0b6 100644 --- a/tests/Spec/Ltl.hs +++ b/tests/Spec/Ltl.hs @@ -3,7 +3,7 @@ module Spec.Ltl where import Control.Monad (MonadPlus (..), guard, replicateM, void) -import Cooked.Ltl +import Cooked.MockChain.Ltl import Cooked.MockChain.Testing import Data.Maybe import Polysemy From 9387fb0cd00d025d09249d2774487985039b8589 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 18:05:11 +0200 Subject: [PATCH 32/39] Flatten Effect modules and drop MockChain prefix from effect types Flatten the Effect/Read/ sub-directory into Effect/ and rename the three weakly-named modules: Read.Chain -> Query, Read.Conf -> Params, Write -> Override. Since every effect is backend-agnostic (it has both a runMockChain* and a runBlockChain* interpreter), drop the misleading MockChain prefix from the effect types themselves: MockChainReadChain -> Query, MockChainReadConf -> Params, MockChainWrite -> Override, MockChainLog -> Log, MockChainMisc -> Misc, MockChainSubmit -> Submit, MockChainTime -> Time, MockChainValidate -> Validate. Interpreters keep the run convention. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cooked-validators.cabal | 6 +- doc/BALANCING.md | 8 +- doc/CHEATSHEET.md | 2 +- src/Cooked/Automation.hs | 10 +-- .../Automation/AutoFilling/Constitution.hs | 6 +- src/Cooked/Automation/AutoFilling/MinAda.hs | 10 +-- .../AutoFilling/ReferenceScripts.hs | 6 +- .../Automation/AutoFilling/Withdrawals.hs | 4 +- src/Cooked/Automation/Balancing.hs | 34 +++---- src/Cooked/Automation/GenerateTx/Body.hs | 16 ++-- .../Automation/GenerateTx/Certificate.hs | 14 +-- .../Automation/GenerateTx/Collateral.hs | 6 +- src/Cooked/Automation/GenerateTx/Input.hs | 4 +- src/Cooked/Automation/GenerateTx/Mint.hs | 4 +- src/Cooked/Automation/GenerateTx/Output.hs | 6 +- src/Cooked/Automation/GenerateTx/Proposal.hs | 8 +- .../Automation/GenerateTx/ReferenceInputs.hs | 4 +- .../Automation/GenerateTx/Withdrawals.hs | 6 +- src/Cooked/Automation/GenerateTx/Witness.hs | 6 +- src/Cooked/Effect.hs | 6 +- src/Cooked/Effect/Log.hs | 14 +-- src/Cooked/Effect/Misc.hs | 46 +++++----- src/Cooked/Effect/{Write.hs => Override.hs} | 44 +++++----- src/Cooked/Effect/{Read/Conf.hs => Params.hs} | 62 ++++++------- src/Cooked/Effect/{Read/Chain.hs => Query.hs} | 84 +++++++++--------- src/Cooked/Effect/Submission.hs | 26 +++--- src/Cooked/Effect/Time.hs | 54 ++++++------ src/Cooked/Effect/Validation.hs | 40 ++++----- src/Cooked/MockChain/Instances.hs | 88 +++++++++---------- src/Cooked/MockChain/Runnable.hs | 10 +-- src/Cooked/MockChain/Testing.hs | 18 ++-- src/Cooked/MockChain/Tweak.hs | 8 +- tests/Spec/Slot.hs | 2 +- 33 files changed, 331 insertions(+), 331 deletions(-) rename src/Cooked/Effect/{Write.hs => Override.hs} (78%) rename src/Cooked/Effect/{Read/Conf.hs => Params.hs} (83%) rename src/Cooked/Effect/{Read/Chain.hs => Query.hs} (91%) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 90ef0a62c..94c935ad7 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -45,12 +45,12 @@ library Cooked.Effect Cooked.Effect.Log Cooked.Effect.Misc - Cooked.Effect.Read.Chain - Cooked.Effect.Read.Conf + Cooked.Effect.Override + Cooked.Effect.Params + Cooked.Effect.Query Cooked.Effect.Submission Cooked.Effect.Time Cooked.Effect.Validation - Cooked.Effect.Write Cooked.MockChain Cooked.MockChain.Instances Cooked.MockChain.Ltl diff --git a/doc/BALANCING.md b/doc/BALANCING.md index a311692d8..ae25a9368 100644 --- a/doc/BALANCING.md +++ b/doc/BALANCING.md @@ -43,14 +43,14 @@ Our balancing function is signed as follows: ``` haskell balanceTxSkel :: - (Members '[MockChainRead, MockChainLog, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[Query, Log, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => TxSkel -> Sem effs ExtendedTxSkel ``` The library is built on [Polysemy] effects rather than a concrete monad, so the balancing capabilities are expressed as the effect constraints -`Members '[MockChainRead, MockChainLog, Error MockChainError, Error +`Members '[Query, Log, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs` and the result lives in `Sem effs`. This function takes a skeleton and returns an `ExtendedTxSkel`, a record bundling @@ -379,7 +379,7 @@ signature: ``` haskell reachValue :: - (Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Error P.Ledger.ToCardanoError] effs) => Utxos -> -- candidate utxos, type Utxos = [(Api.TxOutRef, TxSkelOut)] Api.Value -> -- the target value to reach Integer -> -- the maximum number of utxos allowed in a subset @@ -476,7 +476,7 @@ within this interval. The function that performs this computation is ``` haskell computeFeeAndBalance :: - (Members '[MockChainRead, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[Query, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => Peer -> -- the balancing user Fee -> -- lower bound of the search interval Fee -> -- upper bound of the search interval diff --git a/doc/CHEATSHEET.md b/doc/CHEATSHEET.md index a58e86ec3..8abbd439a 100644 --- a/doc/CHEATSHEET.md +++ b/doc/CHEATSHEET.md @@ -124,7 +124,7 @@ myTrace = do * In a direct set of custom or builtin effects: ```haskell -myTrace :: (Members '[MockChainLog, MockChainRead, MyFirstEff, ...] effs) => Sem effs () +myTrace :: (Members '[Log, Query, MyFirstEff, ...] effs) => Sem effs () myTrace = do ... ``` diff --git a/src/Cooked/Automation.hs b/src/Cooked/Automation.hs index 0ea4bb433..60e0f3b0f 100644 --- a/src/Cooked/Automation.hs +++ b/src/Cooked/Automation.hs @@ -27,8 +27,8 @@ import Cooked.Automation.GenerateTx.ReferenceInputs as X import Cooked.Automation.GenerateTx.Withdrawals as X import Cooked.Automation.GenerateTx.Witness as X import Cooked.Effect.Log -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Runtime.Error import Cooked.Skeleton import Cooked.Tweak.Common @@ -51,9 +51,9 @@ runAutomationPipeline :: ( Members '[ Error P.Ledger.ToCardanoError, Error MockChainError, - MockChainLog, - MockChainReadChain, - MockChainReadConf, + Log, + Query, + Params, Fail ] effs diff --git a/src/Cooked/Automation/AutoFilling/Constitution.hs b/src/Cooked/Automation/AutoFilling/Constitution.hs index baf040c96..855e95d48 100644 --- a/src/Cooked/Automation/AutoFilling/Constitution.hs +++ b/src/Cooked/Automation/AutoFilling/Constitution.hs @@ -9,7 +9,7 @@ where import Control.Monad import Control.Monad.Extra import Cooked.Effect.Log -import Cooked.Effect.Read.Chain +import Cooked.Effect.Query import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -25,9 +25,9 @@ import Polysemy -- constitution script has been successfully auto-filled. autoFillConstitution :: ( Members - '[ MockChainReadChain, + '[ Query, Tweak, - MockChainLog + Log ] effs ) => diff --git a/src/Cooked/Automation/AutoFilling/MinAda.hs b/src/Cooked/Automation/AutoFilling/MinAda.hs index beb488f7b..9e6327bda 100644 --- a/src/Cooked/Automation/AutoFilling/MinAda.hs +++ b/src/Cooked/Automation/AutoFilling/MinAda.hs @@ -13,8 +13,8 @@ import Cardano.Ledger.Shelley.Core qualified as Shelley import Control.Monad import Cooked.Automation.GenerateTx.Output import Cooked.Effect.Log -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -28,7 +28,7 @@ import Polysemy.Error -- | Compute the required minimal ADA for a given output getTxSkelOutMinAda :: - (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error P.Ledger.ToCardanoError] effs) => TxSkelOut -> Sem effs Integer getTxSkelOutMinAda txSkelOut = do @@ -45,7 +45,7 @@ getTxSkelOutMinAda txSkelOut = do -- will increase the size of the UTXO which in turn might need more ADA. toTxSkelOutWithMinAda :: forall effs. - (Members '[MockChainReadChain, MockChainReadConf, MockChainLog, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Log, Error P.Ledger.ToCardanoError] effs) => TxSkelOut -> Sem effs TxSkelOut -- The auto adjustment is disabled so nothing is done here @@ -72,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, MockChainReadChain, MockChainReadConf, MockChainLog, Error P.Ledger.ToCardanoError] effs) => + (Members '[Tweak, Query, Params, Log, Error P.Ledger.ToCardanoError] effs) => Sem effs () autoFillMinAda = traverseTweak (txSkelOutputsL % traversed) toTxSkelOutWithMinAda diff --git a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs index e8ea8ce2f..5bf37d7e6 100644 --- a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs +++ b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs @@ -9,7 +9,7 @@ where import Control.Monad import Cooked.Effect.Log -import Cooked.Effect.Read.Chain +import Cooked.Effect.Query import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Query @@ -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, MockChainReadChain] effs) => + (Members '[Log, Query] 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, MockChainReadChain, MockChainLog] effs) => + (Members '[Tweak, Query, Log] effs) => Sem effs () autoFillReferenceScripts = do inputsKeys <- viewTweak $ txSkelInputsL % to Map.keys diff --git a/src/Cooked/Automation/AutoFilling/Withdrawals.hs b/src/Cooked/Automation/AutoFilling/Withdrawals.hs index 122fda4d9..76421e3d1 100644 --- a/src/Cooked/Automation/AutoFilling/Withdrawals.hs +++ b/src/Cooked/Automation/AutoFilling/Withdrawals.hs @@ -6,7 +6,7 @@ module Cooked.Automation.AutoFilling.Withdrawals where import Cooked.Effect.Log -import Cooked.Effect.Read.Chain +import Cooked.Effect.Query 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 '[MockChainReadChain, Tweak, MockChainLog] effs) => + (Members '[Query, Tweak, Log] effs) => Sem effs () autoFillWithdrawalAmounts = do traverseTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI % traversed) $ \withdrawal -> do diff --git a/src/Cooked/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs index 6563878ae..903d48aea 100644 --- a/src/Cooked/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -18,8 +18,8 @@ import Cooked.Automation.AutoFilling.MinAda import Cooked.Automation.GenerateTx.Body import Cooked.Automation.GenerateTx.Output import Cooked.Effect.Log -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Runtime.Error import Cooked.Skeleton import Cooked.Utilities.Aliases @@ -65,9 +65,9 @@ data ExtendedTxSkel = ExtendedTxSkel -- associated elements. balanceTxSkel :: ( Members - '[ MockChainReadChain, - MockChainReadConf, - MockChainLog, + '[ Query, + Params, + Log, Error MockChainError, Error P.Ledger.ToCardanoError, Fail @@ -170,8 +170,8 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- This uses a dichotomic search for an optimal "balanceable around" fee. computeFeeAndBalance :: ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error MockChainError, Error P.Ledger.ToCardanoError, Fail @@ -235,8 +235,8 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske -- number of collateral inputs authorized by protocol parameters. collateralsFromFee :: ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error MockChainError, Error P.Ledger.ToCardanoError ] @@ -278,8 +278,8 @@ collateralsFromFee fee (Just (collateralIns, returnCollateralUser)) = do reachValue :: forall effs. ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error P.Ledger.ToCardanoError ] effs @@ -418,8 +418,8 @@ reachValue (Map.toList -> utxos) target fuel outputOrUser = do -- and collaterals estimateTxSkelFee :: ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error MockChainError, Error P.Ledger.ToCardanoError, Fail @@ -449,8 +449,8 @@ estimateTxSkelFee skel fee mCollaterals = do -- value + withdrawn value = output value + burned value + fee + deposits computeBalancedTxSkel :: ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error MockChainError, Error P.Ledger.ToCardanoError ] @@ -540,8 +540,8 @@ computeBalancedTxSkel balancingUser balancingUtxos txSkel@TxSkel {..} (Script.lo -- for more information getMinAndMaxFee :: ( Members - '[ MockChainReadChain, - MockChainReadConf + '[ Query, + Params ] effs ) => diff --git a/src/Cooked/Automation/GenerateTx/Body.hs b/src/Cooked/Automation/GenerateTx/Body.hs index 265015512..7c60923d4 100644 --- a/src/Cooked/Automation/GenerateTx/Body.hs +++ b/src/Cooked/Automation/GenerateTx/Body.hs @@ -21,8 +21,8 @@ import Cooked.Automation.GenerateTx.Proposal import Cooked.Automation.GenerateTx.ReferenceInputs import Cooked.Automation.GenerateTx.Withdrawals import Cooked.Automation.GenerateTx.Witness -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Runtime.Error import Cooked.Skeleton import Cooked.Utilities.Aliases @@ -41,8 +41,8 @@ import Witherable -- | Generates a body content from a skeleton txSkelToTxBodyContent :: ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error MockChainError, Error P.Ledger.ToCardanoError, Fail @@ -95,8 +95,8 @@ txBodyContentToTxBody = -- | Generates an index with utxos known to a 'TxSkel' txSkelToIndex :: ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error P.Ledger.ToCardanoError ] effs @@ -125,8 +125,8 @@ txSkelToIndex txSkel mCollaterals = do -- returned. txSkelToTxBody :: ( Members - '[ MockChainReadChain, - MockChainReadConf, + '[ Query, + Params, Error P.Ledger.ToCardanoError, Error MockChainError, Fail diff --git a/src/Cooked/Automation/GenerateTx/Certificate.hs b/src/Cooked/Automation/GenerateTx/Certificate.hs index 08176b254..456b67af9 100644 --- a/src/Cooked/Automation/GenerateTx/Certificate.hs +++ b/src/Cooked/Automation/GenerateTx/Certificate.hs @@ -9,8 +9,8 @@ import Cardano.Ledger.PoolParams qualified as C.Ledger import Cardano.Ledger.Shelley.TxCert qualified as Shelley import Cooked.Automation.GenerateTx.Credential import Cooked.Automation.GenerateTx.Witness -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Runtime.Error import Cooked.Skeleton.Certificate import Cooked.Skeleton.User @@ -25,7 +25,7 @@ import Polysemy.Error import Polysemy.Fail toDRep :: - (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error P.Ledger.ToCardanoError] effs) => Api.DRep -> Sem effs C.Ledger.DRep toDRep Api.DRepAlwaysAbstain = return C.Ledger.DRepAlwaysAbstain @@ -33,7 +33,7 @@ toDRep Api.DRepAlwaysNoConfidence = return C.Ledger.DRepAlwaysNoConfidence toDRep (Api.DRep (Api.DRepCredential cred)) = C.Ledger.DRepCredential <$> toDRepCredential cred toDelegatee :: - (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error P.Ledger.ToCardanoError] effs) => Api.Delegatee -> Sem effs Conway.Delegatee toDelegatee (Api.DelegStake pkh) = Conway.DelegStake <$> toStakePoolKeyHash pkh @@ -41,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 '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelCertificate -> Sem effs (Cardano.Certificate Cardano.ConwayEra) toCertificate txSkelCert = @@ -90,7 +90,7 @@ toCertificate txSkelCert = Conway.ConwayTxCertGov . (`Conway.ConwayResignCommitteeColdKey` SNothing) <$> toColdCredential cred toCertificateWitness :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelCertificate -> Sem effs (Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra)) toCertificateWitness = @@ -104,7 +104,7 @@ toCertificateWitness = -- | Builds a 'Cardano.TxCertificates' from a list of 'TxSkelCertificate' toCertificates :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => [TxSkelCertificate] -> Sem effs (Cardano.TxCertificates Cardano.BuildTx Cardano.ConwayEra) toCertificates = diff --git a/src/Cooked/Automation/GenerateTx/Collateral.hs b/src/Cooked/Automation/GenerateTx/Collateral.hs index 8359ad930..0504438ef 100644 --- a/src/Cooked/Automation/GenerateTx/Collateral.hs +++ b/src/Cooked/Automation/GenerateTx/Collateral.hs @@ -7,8 +7,8 @@ where import Cardano.Api qualified as Cardano import Cooked.Automation.GenerateTx.Output -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Skeleton.Output import Cooked.Skeleton.Value import Cooked.Utilities.Aliases @@ -32,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 '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error P.Ledger.ToCardanoError] effs) => Maybe Collaterals -> Sem effs diff --git a/src/Cooked/Automation/GenerateTx/Input.hs b/src/Cooked/Automation/GenerateTx/Input.hs index af029e901..432ce614b 100644 --- a/src/Cooked/Automation/GenerateTx/Input.hs +++ b/src/Cooked/Automation/GenerateTx/Input.hs @@ -3,7 +3,7 @@ module Cooked.Automation.GenerateTx.Input (toTxInAndWitness) where import Cardano.Api qualified as Cardano import Cooked.Automation.GenerateTx.Witness -import Cooked.Effect.Read.Chain +import Cooked.Effect.Query import Cooked.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 '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => (Api.TxOutRef, TxSkelRedeemer) -> Sem effs diff --git a/src/Cooked/Automation/GenerateTx/Mint.hs b/src/Cooked/Automation/GenerateTx/Mint.hs index 23c9da787..8f75a9289 100644 --- a/src/Cooked/Automation/GenerateTx/Mint.hs +++ b/src/Cooked/Automation/GenerateTx/Mint.hs @@ -4,7 +4,7 @@ module Cooked.Automation.GenerateTx.Mint (toMintValue) where import Cardano.Api qualified as Cardano import Control.Monad import Cooked.Automation.GenerateTx.Witness -import Cooked.Effect.Read.Chain +import Cooked.Effect.Query import Cooked.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 '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, 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/Automation/GenerateTx/Output.hs b/src/Cooked/Automation/GenerateTx/Output.hs index cb3614d80..1465faf2f 100644 --- a/src/Cooked/Automation/GenerateTx/Output.hs +++ b/src/Cooked/Automation/GenerateTx/Output.hs @@ -2,8 +2,8 @@ module Cooked.Automation.GenerateTx.Output (toCardanoTxOut) where import Cardano.Api qualified as Cardano -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Skeleton.Datum import Cooked.Skeleton.Output import Ledger.Tx.CardanoAPI qualified as P.Ledger @@ -15,7 +15,7 @@ import Polysemy.Error -- | Converts a 'TxSkelOut' to the corresponding 'Cardano.TxOut' toCardanoTxOut :: - (Members '[MockChainReadChain, MockChainReadConf, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error P.Ledger.ToCardanoError] effs) => TxSkelOut -> Sem effs (Cardano.TxOut Cardano.CtxTx Cardano.ConwayEra) toCardanoTxOut output = do diff --git a/src/Cooked/Automation/GenerateTx/Proposal.hs b/src/Cooked/Automation/GenerateTx/Proposal.hs index 7ca27e143..46001966f 100644 --- a/src/Cooked/Automation/GenerateTx/Proposal.hs +++ b/src/Cooked/Automation/GenerateTx/Proposal.hs @@ -12,8 +12,8 @@ import Control.Monad import Cooked.Automation.GenerateTx.Anchor import Cooked.Automation.GenerateTx.Credential import Cooked.Automation.GenerateTx.Witness -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Runtime.Error import Cooked.Skeleton.Proposal import Cooked.Skeleton.User @@ -85,7 +85,7 @@ toPParamsUpdate pChange ppu = -- | Translates a given skeleton proposal into a governance action toGovAction :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => GovernanceAction a -> StrictMaybe Conway.ScriptHash -> Sem effs (Conway.GovAction Emulator.EmulatorEra) @@ -101,7 +101,7 @@ toGovAction (TreasuryWithdrawals (Map.toList -> withdrawals)) sHash = -- | Translates a list of skeleton proposals into a proposal procedures toProposalProcedures :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, 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/Automation/GenerateTx/ReferenceInputs.hs b/src/Cooked/Automation/GenerateTx/ReferenceInputs.hs index 3fa90be1d..c979aab1c 100644 --- a/src/Cooked/Automation/GenerateTx/ReferenceInputs.hs +++ b/src/Cooked/Automation/GenerateTx/ReferenceInputs.hs @@ -2,7 +2,7 @@ module Cooked.Automation.GenerateTx.ReferenceInputs (toInsReference) where import Cardano.Api qualified as Cardano -import Cooked.Effect.Read.Chain +import Cooked.Effect.Query 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 '[MockChainReadChain, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Error P.Ledger.ToCardanoError] effs) => TxSkel -> Sem effs (Cardano.TxInsReference Cardano.BuildTx Cardano.ConwayEra) toInsReference skel = do diff --git a/src/Cooked/Automation/GenerateTx/Withdrawals.hs b/src/Cooked/Automation/GenerateTx/Withdrawals.hs index c2e52eae4..82b91e8d7 100644 --- a/src/Cooked/Automation/GenerateTx/Withdrawals.hs +++ b/src/Cooked/Automation/GenerateTx/Withdrawals.hs @@ -4,8 +4,8 @@ module Cooked.Automation.GenerateTx.Withdrawals (toWithdrawals) where import Cardano.Api qualified as Cardano import Control.Monad import Cooked.Automation.GenerateTx.Witness -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Runtime.Error import Cooked.Skeleton.User import Cooked.Skeleton.Withdrawal @@ -20,7 +20,7 @@ import Polysemy.Error -- | Takes a 'TxSkelWithdrawals' and transforms it into a 'Cardano.TxWithdrawals' toWithdrawals :: - (Members '[MockChainReadChain, MockChainReadConf, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, 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/Automation/GenerateTx/Witness.hs b/src/Cooked/Automation/GenerateTx/Witness.hs index 1ec6c60a2..faf94f9c0 100644 --- a/src/Cooked/Automation/GenerateTx/Witness.hs +++ b/src/Cooked/Automation/GenerateTx/Witness.hs @@ -6,7 +6,7 @@ module Cooked.Automation.GenerateTx.Witness where import Cardano.Api qualified as Cardano -import Cooked.Effect.Read.Chain +import Cooked.Effect.Query import Cooked.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 '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, 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 '[MockChainReadChain, Error MockChainError, Error P.Ledger.ToCardanoError] effs, + ( Members '[Query, Error MockChainError, Error P.Ledger.ToCardanoError] effs, ToVScript a ) => a -> diff --git a/src/Cooked/Effect.hs b/src/Cooked/Effect.hs index 3ca6cce0c..cc771b560 100644 --- a/src/Cooked/Effect.hs +++ b/src/Cooked/Effect.hs @@ -6,9 +6,9 @@ module Cooked.Effect (module X) where import Cooked.Effect.Log as X import Cooked.Effect.Misc as X -import Cooked.Effect.Read.Chain as X -import Cooked.Effect.Read.Conf as X +import Cooked.Effect.Override as X +import Cooked.Effect.Params as X +import Cooked.Effect.Query as X import Cooked.Effect.Submission as X import Cooked.Effect.Time as X import Cooked.Effect.Validation as X -import Cooked.Effect.Write as X diff --git a/src/Cooked/Effect/Log.hs b/src/Cooked/Effect/Log.hs index 33717a76d..e3ea8b6d2 100644 --- a/src/Cooked/Effect/Log.hs +++ b/src/Cooked/Effect/Log.hs @@ -12,7 +12,7 @@ module Cooked.Effect.Log MockChainLogEntry (..), -- * Logging effect - MockChainLog, + Log, runMockChainLog, -- * Logging primitive @@ -73,19 +73,19 @@ data MockChainLogEntry deriving (Show) -- | An effect to allow logging of mockchain events -data MockChainLog :: Effect where - LogEvent :: MockChainLogEntry -> MockChainLog m () +data Log :: Effect where + LogEvent :: MockChainLogEntry -> Log m () -makeSem_ ''MockChainLog +makeSem_ ''Log --- | Interpreting a `MockChainLog` in terms of a writer of +-- | Interpreting a `Log` in terms of a writer of -- @[MockChainLogEntry]@ runMockChainLog :: (Member (Writer j) effs) => (MockChainLogEntry -> j) -> - Sem (MockChainLog : effs) a -> + Sem (Log : effs) a -> Sem effs a runMockChainLog inject = interpret $ \(LogEvent event) -> tell $ inject event -- | Logs an internal event occurring while processing a transaction skeleton -logEvent :: (Member MockChainLog effs) => MockChainLogEntry -> Sem effs () +logEvent :: (Member Log effs) => MockChainLogEntry -> Sem effs () diff --git a/src/Cooked/Effect/Misc.hs b/src/Cooked/Effect/Misc.hs index 740af11bd..6f132b23c 100644 --- a/src/Cooked/Effect/Misc.hs +++ b/src/Cooked/Effect/Misc.hs @@ -4,7 +4,7 @@ -- operating a mockchain without interacting with the mockchain state itself. module Cooked.Effect.Misc ( -- * Misc effect - MockChainMisc (..), + Misc (..), runMockChainMisc, runBlockChainMisc, @@ -43,80 +43,80 @@ import Prettyprinter qualified as PP import Prettyprinter.Render.Text qualified as PP -- | An effect that corresponds to extra QOL capabilities of the MockChain -data MockChainMisc :: Effect where - Define :: (ToHash a) => String -> a -> MockChainMisc m a - Note :: (PrettyCookedOpts -> DocCooked) -> MockChainMisc m () - Assert :: (PrettyCookedOpts -> DocCooked) -> Bool -> MockChainMisc m () +data Misc :: Effect where + Define :: (ToHash a) => String -> a -> Misc m a + Note :: (PrettyCookedOpts -> DocCooked) -> Misc m () + Assert :: (PrettyCookedOpts -> DocCooked) -> Bool -> Misc m () -makeSem_ ''MockChainMisc +makeSem_ ''Misc -- | Stores an alias matching a hashable data for pretty printing purpose -define :: forall effs a. (Member MockChainMisc effs, ToHash a) => String -> a -> Sem effs a +define :: forall effs a. (Member Misc effs, ToHash a) => String -> a -> Sem effs a -- | Like `define`, but binds the result of a monadic computation instead -defineM :: (Member MockChainMisc effs, ToHash a) => String -> Sem effs a -> Sem effs a +defineM :: (Member Misc effs, ToHash a) => String -> Sem effs a -> Sem effs a defineM name = (define name =<<) -- | Takes note of an element represented as its rendering function to trace at -- the end of the run -note :: forall effs. (Member MockChainMisc effs) => (PrettyCookedOpts -> DocCooked) -> Sem effs () +note :: forall effs. (Member Misc effs) => (PrettyCookedOpts -> DocCooked) -> Sem effs () -- | Takes note of a pretty-printable element to trace at the end of the run -noteP :: forall effs s. (Member MockChainMisc effs, PrettyCooked s) => s -> Sem effs () +noteP :: forall effs s. (Member Misc effs, PrettyCooked s) => s -> Sem effs () noteP doc = note (`prettyCookedOpt` doc) -- | Takes note of a pretty-printable element as list with a title, to trace at -- the end of the run -noteL :: forall effs l. (Member MockChainMisc effs, PrettyCookedList l) => String -> l -> Sem effs () +noteL :: forall effs l. (Member Misc effs, PrettyCookedList l) => String -> l -> Sem effs () noteL title docs = note $ \opts -> prettyItemize opts (prettyCooked title) "-" docs -- | Takes note of a showable element to trace at the end of the run -noteW :: forall effs s. (Member MockChainMisc effs, Show s) => s -> Sem effs () +noteW :: forall effs s. (Member Misc effs, Show s) => s -> Sem effs () noteW = note . const . PP.viaShow -- | Takes note of a String to trace at the end of the run -noteS :: forall effs. (Member MockChainMisc effs) => String -> Sem effs () +noteS :: forall effs. (Member Misc effs) => String -> Sem effs () noteS = noteP -- | Ensures a specific property holds, rendering the provided message with the -- ambient pretty-printing options otherwise -assert :: forall effs. (Member MockChainMisc effs) => (PrettyCookedOpts -> DocCooked) -> Bool -> Sem effs () +assert :: forall effs. (Member Misc effs) => (PrettyCookedOpts -> DocCooked) -> Bool -> Sem effs () -- | Like `assert`, but with a pretty-printable message -assertP :: forall effs s. (Member MockChainMisc effs, PrettyCooked s) => s -> Bool -> Sem effs () +assertP :: forall effs s. (Member Misc effs, PrettyCooked s) => s -> Bool -> Sem effs () assertP doc = assert (`prettyCookedOpt` doc) -- | Like `assert`, but with a pretty-printable message displayed as a list with -- a title -assertL :: forall effs l. (Member MockChainMisc effs, PrettyCookedList l) => String -> l -> Bool -> Sem effs () +assertL :: forall effs l. (Member Misc effs, PrettyCookedList l) => String -> l -> Bool -> Sem effs () assertL title docs = assert $ \opts -> prettyItemize opts (prettyCooked title) "-" docs -- | Like `assert`, but with a showable message -assertW :: forall effs s. (Member MockChainMisc effs, Show s) => s -> Bool -> Sem effs () +assertW :: forall effs s. (Member Misc effs, Show s) => s -> Bool -> Sem effs () assertW = assert . const . PP.viaShow -- | Like `assert`, but with a `String` message -assertS :: forall effs. (Member MockChainMisc effs) => String -> Bool -> Sem effs () +assertS :: forall effs. (Member Misc effs) => String -> Bool -> Sem effs () assertS = assertP -- | Like `assert`, but with a default error message -assert' :: forall effs. (Member MockChainMisc effs) => Bool -> Sem effs () +assert' :: forall effs. (Member Misc effs) => Bool -> Sem effs () assert' = assertS "Assertion" --- | Interprets a `MockChainMisc` in terms of a writer in @j@ where @j@ can be +-- | Interprets a `Misc` in terms of a writer in @j@ where @j@ can be -- built from either of the three possible parameters of the 3 misc actions. The -- 3 actions only update the state, which is only used at the end of the run. runMockChainMisc :: forall effs a. (Member (Writer MockChainJournal) effs) => - Sem (MockChainMisc : effs) a -> + Sem (Misc : effs) a -> Sem effs a runMockChainMisc = interpret $ \case (Define name hashable) -> tell (fromAlias name $ toHash hashable) >> return hashable (Note s) -> tell $ fromNote s (Assert s b) -> tell $ fromAssert s b --- | Interprets a `MockChainMisc` in the context of a deployed node, running in a +-- | Interprets a `Misc` in the context of a deployed node, running in a -- stack featuring @IO@ (via `Embed`). Contrary to `runMockChainMisc`, which -- gathers everything in a journal to be inspected at the end of the run, this -- interpreter reacts immediately: @@ -138,7 +138,7 @@ runBlockChainMisc :: ] effs ) => - Sem (MockChainMisc : effs) a -> + Sem (Misc : effs) a -> Sem effs a runBlockChainMisc = interpret $ \case Define name hashable -> do diff --git a/src/Cooked/Effect/Write.hs b/src/Cooked/Effect/Override.hs similarity index 78% rename from src/Cooked/Effect/Write.hs rename to src/Cooked/Effect/Override.hs index 6ff252dbd..def48cd09 100644 --- a/src/Cooked/Effect/Write.hs +++ b/src/Cooked/Effect/Override.hs @@ -2,10 +2,10 @@ -- | This module exposes primitives to manually (and artificially) update the -- current state of the blockchain. -module Cooked.Effect.Write - ( -- * The `MockChainWrite` effect - MockChainWrite (..), - runMockChainWrite, +module Cooked.Effect.Override + ( -- * The `Override` effect + Override (..), + runMockChainOverride, -- * Other operations setParams, @@ -24,8 +24,8 @@ import Cooked.Automation.AutoFilling.MinAda import Cooked.Automation.GenerateTx.Body import Cooked.Automation.GenerateTx.Output import Cooked.Effect.Log -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Runtime.Error import Cooked.Runtime.State import Cooked.Skeleton @@ -43,30 +43,30 @@ import Polysemy.State -- | An effect that offers all the primitives that are performing modifications -- on the blockchain state. -data MockChainWrite :: Effect where - SetParams :: Emulator.Params -> MockChainWrite m () - SetConstitutionScript :: (ToVScript s) => s -> MockChainWrite m () - ForceOutputs :: [TxSkelOut] -> MockChainWrite m Utxos +data Override :: Effect where + SetParams :: Emulator.Params -> Override m () + SetConstitutionScript :: (ToVScript s) => s -> Override m () + ForceOutputs :: [TxSkelOut] -> Override m Utxos -makeSem_ ''MockChainWrite +makeSem_ ''Override --- | Interprets the `MockChainWrite` effect -runMockChainWrite :: +-- | Interprets the `Override` effect +runMockChainOverride :: forall effs a. ( Members '[ State EmulatorState, State ChainIndex, Error P.Ledger.ToCardanoError, Error MockChainError, - MockChainLog, - MockChainReadChain, - MockChainReadConf + Log, + Query, + Params ] effs ) => - Sem (MockChainWrite : effs) a -> + Sem (Override : effs) a -> Sem effs a -runMockChainWrite = interpret $ \case +runMockChainOverride = interpret $ \case SetParams params -> do modify $ set emulatorStateParamsL params modify $ over emulatorStateLedgerStateL $ Emulator.updateStateParams params @@ -102,16 +102,16 @@ runMockChainWrite = interpret $ \case return $ Map.fromList outputsList -- | Updates the current parameters -setParams :: (Member MockChainWrite effs) => Emulator.Params -> Sem effs () +setParams :: (Member Override effs) => Emulator.Params -> Sem effs () -- | Sets the current script to act as the official constitution script -setConstitutionScript :: (Member MockChainWrite effs, ToVScript s) => s -> Sem effs () +setConstitutionScript :: (Member Override effs, ToVScript s) => s -> Sem effs () -- | Forces the generation of utxos corresponding to certain -- `TxSkelOut`. Returns the created UTxOs, which might differ from the original -- list if some min ADA adjustment occurred. -forceOutputs :: (Member MockChainWrite effs) => [TxSkelOut] -> Sem effs Utxos +forceOutputs :: (Member Override effs) => [TxSkelOut] -> Sem effs Utxos -- | Same as `forceOutputs`, but discards the returned outputs -forceOutputs_ :: (Member MockChainWrite effs) => [TxSkelOut] -> Sem effs () +forceOutputs_ :: (Member Override effs) => [TxSkelOut] -> Sem effs () forceOutputs_ = void . forceOutputs diff --git a/src/Cooked/Effect/Read/Conf.hs b/src/Cooked/Effect/Params.hs similarity index 83% rename from src/Cooked/Effect/Read/Conf.hs rename to src/Cooked/Effect/Params.hs index 23ac509a6..a4bb257ff 100644 --- a/src/Cooked/Effect/Read/Conf.hs +++ b/src/Cooked/Effect/Params.hs @@ -2,16 +2,16 @@ -- 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.Effect.Read.Chain.MockChainReadChain' effect, +-- user-facing 'Cooked.Effect.Query.Query' effect, -- and they are deliberately not meant to be used directly through the "Cooked" -- umbrella module. -module Cooked.Effect.Read.Conf - ( -- * The 'MockChainReadConf' effect - MockChainReadConf, +module Cooked.Effect.Params + ( -- * The 'Params' effect + Params, - -- * 'MockChainReadConf' interpreters - runMockChainReadConf, - runBlockChainReadConf, + -- * 'Params' interpreters + runMockChainParams, + runBlockChainParams, -- * Queries related to protocol parameters getParams, @@ -53,31 +53,31 @@ import Polysemy.State -- 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.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 +-- 'Cooked.Effect.Query.Query' effect. +data Params :: Effect where + GetParams :: Params m (C.Ledger.PParams Conway.ConwayEra) + GetNetworkId :: Params m Cardano.NetworkId + GetEraHistory :: Params m Cardano.EraHistory + GetSystemStart :: Params m Time.SystemStart -makeSem_ ''MockChainReadConf +makeSem_ ''Params -- | The interpretation for the configuration effect with a stored -- 'EmulatorState' -runMockChainReadConf :: +runMockChainParams :: (Member (State EmulatorState) effs) => - Sem (MockChainReadConf : effs) a -> + Sem (Params : effs) a -> Sem effs a -runMockChainReadConf = interpret $ \case +runMockChainParams = interpret $ \case 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 +-- | Interpret the `Params` 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`). -runBlockChainReadConf :: +runBlockChainParams :: ( Members '[ Embed IO, Error Cardano.UnsupportedNtcVersionError, @@ -87,9 +87,9 @@ runBlockChainReadConf :: ] effs ) => - Sem (MockChainReadConf : effs) a -> + Sem (Params : effs) a -> Sem effs a -runBlockChainReadConf = interpret $ \case +runBlockChainParams = interpret $ \case GetParams -> queryAndHandleErrors $ Cardano.queryProtocolParameters Cardano.ShelleyBasedEraConway GetNetworkId -> asks Cardano.localNodeNetworkId GetEraHistory -> queryAndHandleError Cardano.queryEraHistory @@ -107,29 +107,29 @@ runBlockChainReadConf = interpret $ \case -- | Returns the emulator parameters, including protocol parameters getParams :: - (Member MockChainReadConf effs) => + (Member Params effs) => Sem effs (C.Ledger.PParams Conway.ConwayEra) -- | Returns the network id of the current chain getNetworkId :: - (Member MockChainReadConf effs) => + (Member Params 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) => + (Member Params 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) => + (Member Params effs) => Sem effs Time.SystemStart -- | Retrieves the required governance action deposit amount govActionDeposit :: - (Member MockChainReadConf effs) => + (Member Params effs) => Sem effs Api.Lovelace govActionDeposit = getParams @@ -139,7 +139,7 @@ govActionDeposit = -- | Retrieves the required drep deposit amount dRepDeposit :: - (Member MockChainReadConf effs) => + (Member Params effs) => Sem effs Api.Lovelace dRepDeposit = getParams @@ -149,7 +149,7 @@ dRepDeposit = -- | Retrieves the required stake address deposit amount stakeAddressDeposit :: - (Member MockChainReadConf effs) => + (Member Params effs) => Sem effs Api.Lovelace stakeAddressDeposit = getParams @@ -159,7 +159,7 @@ stakeAddressDeposit = -- | Retrieves the required stake pool deposit amount stakePoolDeposit :: - (Member MockChainReadConf effs) => + (Member Params effs) => Sem effs Api.Lovelace stakePoolDeposit = getParams @@ -173,7 +173,7 @@ stakePoolDeposit = -- 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) => + (Member Params effs) => TxSkel -> Sem effs Api.Lovelace txSkelDepositedValueInCertificates txSkel = do @@ -202,7 +202,7 @@ txSkelDepositedValueInCertificates txSkel = do -- | Retrieves the total amount of lovelace deposited in proposals in this -- skeleton (equal to `govActionDeposit` times the number of proposals) txSkelDepositedValueInProposals :: - (Member MockChainReadConf effs) => + (Member Params effs) => TxSkel -> Sem effs Api.Lovelace txSkelDepositedValueInProposals TxSkel {txSkelProposals} = diff --git a/src/Cooked/Effect/Read/Chain.hs b/src/Cooked/Effect/Query.hs similarity index 91% rename from src/Cooked/Effect/Read/Chain.hs rename to src/Cooked/Effect/Query.hs index da5983ef8..19128a8ce 100644 --- a/src/Cooked/Effect/Read/Chain.hs +++ b/src/Cooked/Effect/Query.hs @@ -3,18 +3,18 @@ -- or rewards. It also provides the 'UtxoSearch' framework, a convenient way to -- look through UTxOs, filter them, and extract pieces of information from them. -- Time-related queries live in the separate --- 'Cooked.Effect.Time.MockChainTime' effect. The lower-level +-- 'Cooked.Effect.Time.Time' effect. The lower-level -- configuration primitives (protocol parameters, network id, era history, system -- start) live in the internal --- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect, which this +-- 'Cooked.Effect.Params.Params' effect, which this -- effect relies on during its own interpretation. -module Cooked.Effect.Read.Chain - ( -- * The 'MockChainReadChain' effect - MockChainReadChain, +module Cooked.Effect.Query + ( -- * The 'Query' effect + Query, - -- * 'MockChainReadChain' interpreters - runMockChainReadChain, - runBlockChainReadChain, + -- * 'Query' interpreters + runMockChainQuery, + runBlockChainQuery, -- * Queries related to `Cooked.Skeleton.TxSkel` txSkelAllScripts, @@ -82,7 +82,7 @@ import Cardano.Api.Ledger qualified as Cardano hiding (TxIn) import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad import Cooked.Automation.GenerateTx.Credential -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params import Cooked.Runtime.Error import Cooked.Runtime.State import Cooked.Skeleton @@ -114,20 +114,20 @@ import Witherable (filterA, witherM) -- mockchain. As its name suggests, this effect is read-only and does not alter -- the state in any way. This is the user-facing read effect; its interpreters -- rely on the internal --- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect to resolve the +-- 'Cooked.Effect.Params.Params' effect to resolve the -- fixed chain configuration. -data MockChainReadChain :: Effect where - TxSkelOutByRef :: Api.TxOutRef -> MockChainReadChain m TxSkelOut - 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) +data Query :: Effect where + TxSkelOutByRef :: Api.TxOutRef -> Query m TxSkelOut + AllUtxos :: Query m Utxos + UtxosAt :: (Script.ToAddress a) => a -> Query m Utxos + GetConstitutionScript :: Query m (Maybe VScript) + GetCurrentReward :: (Script.ToCredential c) => c -> Query m (Maybe Api.Lovelace) -makeSem_ ''MockChainReadChain +makeSem_ ''Query -- | Returns all scripts involved in this 'TxSkel' txSkelAllScripts :: - (Member MockChainReadChain effs) => + (Member Query effs) => TxSkel -> Sem effs [VScript] txSkelAllScripts txSkel = do @@ -138,7 +138,7 @@ txSkelAllScripts txSkel = do -- | Returns all scripts which guard transaction inputs txSkelInputScripts :: - (Member MockChainReadChain effs) => + (Member Query effs) => TxSkel -> Sem effs [VScript] txSkelInputScripts = @@ -149,7 +149,7 @@ txSkelInputScripts = -- | look up the UTxOs the transaction consumes, and sum their values. txSkelInputValue :: - (Member MockChainReadChain effs) => + (Member Query effs) => TxSkel -> Sem effs Api.Value txSkelInputValue = @@ -160,12 +160,12 @@ txSkelInputValue = -- | Returns a list of all currently known outputs allUtxos :: - (Member MockChainReadChain effs) => + (Member Query effs) => Sem effs Utxos -- | Returns a list of all UTxOs at a certain address. utxosAt :: - ( Member MockChainReadChain effs, + ( Member Query effs, Script.ToAddress cred ) => cred -> @@ -173,7 +173,7 @@ utxosAt :: -- | Returns an output given a reference to it txSkelOutByRef :: - (Member MockChainReadChain effs) => + (Member Query effs) => Api.TxOutRef -> Sem effs TxSkelOut @@ -183,7 +183,7 @@ txSkelOutByRef :: -- interest right from the start and avoid querying the chain for them -- afterwards using 'allUtxos' or similar functions. utxosFromCardanoTx :: - (Member MockChainReadChain effs) => + (Member Query effs) => P.Ledger.CardanoTx -> Sem effs [(Api.TxOutRef, TxSkelOut)] utxosFromCardanoTx = @@ -194,7 +194,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 MockChainReadChain effs) => + (Member Query effs) => [Api.TxOutRef] -> Sem effs (Map Api.TxOutRef TxSkelOut) lookupUtxos = @@ -204,7 +204,7 @@ lookupUtxos = -- | Retrieves an output and views a specific element out of it viewByRef :: - ( Member MockChainReadChain effs, + ( Member Query effs, Is g A_Getter ) => Optic' g is TxSkelOut c -> @@ -214,7 +214,7 @@ viewByRef optic = (view optic <$>) . txSkelOutByRef -- | Retrieves an output and previews a specific element out of it previewByRef :: - ( Member MockChainReadChain effs, + ( Member Query effs, Is af An_AffineFold ) => Optic' af is TxSkelOut c -> @@ -224,12 +224,12 @@ previewByRef optic = (preview optic <$>) . txSkelOutByRef -- | Gets the current official constitution script getConstitutionScript :: - (Member MockChainReadChain effs) => + (Member Query effs) => Sem effs (Maybe VScript) -- | Gets the current reward associated with a credential getCurrentReward :: - ( Member MockChainReadChain effs, + ( Member Query effs, Script.ToCredential c ) => c -> @@ -237,7 +237,7 @@ getCurrentReward :: -- | The interpretation for read-only effect with a stored 'EmulatorState' and -- 'ChainIndex' -runMockChainReadChain :: +runMockChainQuery :: forall effs a. ( Members '[ State EmulatorState, @@ -247,9 +247,9 @@ runMockChainReadChain :: ] effs ) => - Sem (MockChainReadChain : effs) a -> + Sem (Query : effs) a -> Sem effs a -runMockChainReadChain = interpret $ \case +runMockChainQuery = interpret $ \case TxSkelOutByRef oRef -> do res <- gets $ Map.lookup oRef . chainIndexOutputs case res of @@ -276,16 +276,16 @@ runMockChainReadChain = interpret $ \case % filtered (decide . fst) % to fst --- | Interpret the `MockChainReadChain` effect by talking to a deployed node +-- | Interpret the `Query` 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.Effect.Read.Conf.MockChainReadConf' effect. -runBlockChainReadChain :: +-- 'Cooked.Effect.Params.Params' effect. +runBlockChainQuery :: forall effs a. ( Members '[ Embed IO, - MockChainReadConf, + Params, Error Cardano.UnsupportedNtcVersionError, Error Cardano.EraMismatch, Error Cardano.AcquiringFailure, @@ -296,9 +296,9 @@ runBlockChainReadChain :: ] effs ) => - Sem (MockChainReadChain : effs) a -> + Sem (Query : effs) a -> Sem effs a -runBlockChainReadChain = interpret $ \case +runBlockChainQuery = interpret $ \case AllUtxos -> queryUtxosAndHandleErrors Cardano.QueryUTxOWhole UtxosAt (Script.toAddress -> addr) -> do networkId <- getNetworkId @@ -453,7 +453,7 @@ getTxOutRefs = fmap Map.keysSet -- | Searches for utxos at a given address with a given filter utxosAtSearch :: - (Member MockChainReadChain effs, Script.ToAddress pkh) => + (Member Query effs, Script.ToAddress pkh) => pkh -> (UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els @@ -461,14 +461,14 @@ utxosAtSearch pkh filters = filters $ beginSearch $ utxosAt pkh -- | Searches for all the known utxos with a given filter allUtxosSearch :: - (Member MockChainReadChain effs) => + (Member Query 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 MockChainReadChain effs) => + (Member Query effs) => Set Api.TxOutRef -> (UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els @@ -481,7 +481,7 @@ txSkelOutByRefSearch utxos filters = -- | Searches for utxos belonging to a given list with no filter txSkelOutByRefSearch' :: - (Member MockChainReadChain effs) => + (Member Query effs) => Set Api.TxOutRef -> UtxoSearch effs '[] txSkelOutByRefSearch' = (`txSkelOutByRefSearch` id) diff --git a/src/Cooked/Effect/Submission.hs b/src/Cooked/Effect/Submission.hs index eab1c19b8..6c8100c7b 100644 --- a/src/Cooked/Effect/Submission.hs +++ b/src/Cooked/Effect/Submission.hs @@ -1,10 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} --- | This module exposes the 'MockChainSubmit' effect, which is responsible for +-- | This module exposes the 'Submit' effect, which is responsible for -- submitting a Cardano transaction for validation. module Cooked.Effect.Submission - ( -- * The 'MockChainSubmit' effect - MockChainSubmit (..), + ( -- * The 'Submit' effect + Submit (..), submitTransaction, -- * Interpretation functions @@ -16,7 +16,7 @@ where import Cardano.Api qualified as Cardano import Cardano.Ledger.Shelley.API.Mempool qualified as Shelley import Cardano.Node.Emulator.Internal.Node qualified as Emulator -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params import Cooked.Runtime.State import Cooked.Utilities.Aliases import Data.Foldable.Extra @@ -29,23 +29,23 @@ import Polysemy.Reader import Polysemy.State -- | An effect allow to submit a transaction for validation -data MockChainSubmit :: Effect where - SubmitTransaction :: Transaction -> MockChainSubmit m SubmissionFailures +data Submit :: Effect where + SubmitTransaction :: Transaction -> Submit m SubmissionFailures -makeSem_ ''MockChainSubmit +makeSem_ ''Submit -- | Submits a transaction for validation, returning a (possibly empty) list of -- submission failures. submitTransaction :: - (Member MockChainSubmit effs) => + (Member Submit effs) => Transaction -> Sem effs SubmissionFailures --- | Interprets the `MockChainSubmit` effect on an emulator +-- | Interprets the `Submit` effect on an emulator runMockChainSubmit :: forall effs a. (Member (State EmulatorState) effs) => - Sem (MockChainSubmit : effs) a -> + Sem (Submit : effs) a -> Sem effs a runMockChainSubmit = interpret $ \case SubmitTransaction cardanoTx -> do @@ -62,7 +62,7 @@ runMockChainSubmit = interpret $ \case -- We return the validation result return submissionFailures --- | Interprets the `MockChainSubmit` effect by submitting the generated +-- | Interprets the `Submit` 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`). @@ -71,13 +71,13 @@ runBlockChainSubmit :: ( Members '[ Embed IO, Error Cardano.EraMismatch, - MockChainReadConf, + Params, Reader Cardano.LocalNodeConnectInfo, Fail ] effs ) => - Sem (MockChainSubmit : effs) a -> + Sem (Submit : effs) a -> Sem effs a runBlockChainSubmit = interpret $ \case SubmitTransaction cardanoTx -> do diff --git a/src/Cooked/Effect/Time.hs b/src/Cooked/Effect/Time.hs index 4778ca3bc..f097dd934 100644 --- a/src/Cooked/Effect/Time.hs +++ b/src/Cooked/Effect/Time.hs @@ -4,13 +4,13 @@ -- conversions between slots and POSIX time ranges) as well as the primitives to -- wait for a given slot or time. The lower-level configuration primitives (era -- history and system start) live in the internal --- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect, which the node +-- 'Cooked.Effect.Params.Params' effect, which the node -- interpreter of this effect relies on. module Cooked.Effect.Time - ( -- * The 'MockChainTime' effect - MockChainTime, + ( -- * The 'Time' effect + Time, - -- * 'MockChainTime' interpreters + -- * 'Time' interpreters runMockChainTime, runBlockChainTime, @@ -37,7 +37,7 @@ import Cardano.Slotting.Time qualified as Time import Control.Concurrent (threadDelay) import Control.Lens qualified as Lens import Control.Monad -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params import Cooked.Runtime.State import Data.Time.Clock import Data.Time.Clock.POSIX @@ -54,42 +54,42 @@ import Polysemy.State -- time of the mockchain. The read-only primitives ('currentSlot', -- 'slotToMSRange', 'getEnclosingSlot') do not alter the state, while the waiting -- primitive ('waitNSlots') advances the current slot. -data MockChainTime :: Effect where - CurrentSlot :: MockChainTime m P.Ledger.Slot - SlotToMSRange :: P.Ledger.Slot -> MockChainTime m (Api.POSIXTime, Api.POSIXTime) - GetEnclosingSlot :: Api.POSIXTime -> MockChainTime m P.Ledger.Slot - WaitNSlots :: Integer -> MockChainTime m P.Ledger.Slot +data Time :: Effect where + CurrentSlot :: Time m P.Ledger.Slot + SlotToMSRange :: P.Ledger.Slot -> Time m (Api.POSIXTime, Api.POSIXTime) + GetEnclosingSlot :: Api.POSIXTime -> Time m P.Ledger.Slot + WaitNSlots :: Integer -> Time m P.Ledger.Slot -makeSem_ ''MockChainTime +makeSem_ ''Time -- | Returns the current slot currentSlot :: - (Member MockChainTime effs) => + (Member Time effs) => Sem effs P.Ledger.Slot -- | Returns the closed ms interval corresponding to the slot with the given -- number. slotToMSRange :: - (Members '[MockChainTime, Fail] effs) => + (Members '[Time, Fail] effs) => P.Ledger.Slot -> Sem effs (Api.POSIXTime, Api.POSIXTime) -- | Returns the closed ms interval corresponding to the current slot currentMSRange :: - (Members '[MockChainTime, Fail] effs) => + (Members '[Time, 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 MockChainTime effs) => + (Member Time effs) => Api.POSIXTime -> Sem effs P.Ledger.Slot -- | The infinite range of slots ending before or at the given time slotRangeBefore :: - (Members '[MockChainTime, Fail] effs) => + (Members '[Time, Fail] effs) => Api.POSIXTime -> Sem effs P.Ledger.SlotRange slotRangeBefore t = do @@ -102,7 +102,7 @@ slotRangeBefore t = do -- | The infinite range of slots starting after or at the given time slotRangeAfter :: - (Members '[MockChainTime, Fail] effs) => + (Members '[Time, Fail] effs) => Api.POSIXTime -> Sem effs P.Ledger.SlotRange slotRangeAfter t = do @@ -112,12 +112,12 @@ slotRangeAfter t = do -- | Waits a certain number of slots and returns the new slot waitNSlots :: - (Member MockChainTime effs) => + (Member Time effs) => Integer -> Sem effs P.Ledger.Slot -- | Wait for a certain slot, or throws an error if the slot is already past -awaitSlot :: (Member MockChainTime effs) => P.Ledger.Slot -> Sem effs P.Ledger.Slot +awaitSlot :: (Member Time effs) => P.Ledger.Slot -> Sem effs P.Ledger.Slot awaitSlot (P.Ledger.Slot targetSlot) = do P.Ledger.Slot now <- currentSlot waitNSlots (targetSlot - now) @@ -125,17 +125,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 :: (Member MockChainTime effs) => Api.POSIXTime -> Sem effs P.Ledger.Slot +awaitEnclosingSlot :: (Member Time 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 '[MockChainTime, Fail] effs) => Integer -> Sem effs P.Ledger.Slot +waitNMSFromSlotLowerBound :: (Members '[Time, 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 '[MockChainTime, Fail] effs) => Integer -> Sem effs P.Ledger.Slot +waitNMSFromSlotUpperBound :: (Members '[Time, Fail] effs) => Integer -> Sem effs P.Ledger.Slot waitNMSFromSlotUpperBound duration = currentMSRange >>= awaitEnclosingSlot . (+ fromIntegral duration) . snd -- | The interpretation for the time effect with a stored 'EmulatorState' @@ -147,7 +147,7 @@ runMockChainTime :: ] effs ) => - Sem (MockChainTime : effs) a -> + Sem (Time : effs) a -> Sem effs a runMockChainTime = interpret $ \case CurrentSlot -> gets $ view $ emulatorStateLedgerStateL % to Emulator.getSlot @@ -174,23 +174,23 @@ runMockChainTime = interpret $ \case modify' $ over emulatorStateLedgerStateL $ Lens.set Emulator.elsSlotL $ fromIntegral newSlot return newSlot --- | Interpret the `MockChainTime` effect by talking to a deployed node through a +-- | Interpret the `Time` 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`). Waiting is -- performed by suspending the thread for the appropriate amount of time. The -- fixed chain configuration is resolved through the internal --- 'Cooked.Effect.Read.Conf.MockChainReadConf' effect. +-- 'Cooked.Effect.Params.Params' effect. runBlockChainTime :: forall effs a. ( Members '[ Embed IO, - MockChainReadConf, + Params, Error Cardano.PastHorizonException, Reader Cardano.LocalNodeConnectInfo ] effs ) => - Sem (MockChainTime : effs) a -> + Sem (Time : effs) a -> Sem effs a runBlockChainTime = interpret $ \case CurrentSlot -> getNodeSlot diff --git a/src/Cooked/Effect/Validation.hs b/src/Cooked/Effect/Validation.hs index 95ce343de..5cb19ade5 100644 --- a/src/Cooked/Effect/Validation.hs +++ b/src/Cooked/Effect/Validation.hs @@ -1,13 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} --- | This module exposes the `MockChainValidate` effect, which is responsible +-- | This module exposes the `Validate` 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.Effect.Validation - ( -- * The `MockChainValidate` effect - MockChainValidate (..), + ( -- * The `Validate` effect + Validate (..), validateTxSkel, validateTxSkel', validateTxSkelL, @@ -22,8 +22,8 @@ import Cardano.Api qualified as Cardano import Control.Monad import Cooked.Automation import Cooked.Effect.Log -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Effect.Submission import Cooked.Runtime.Error import Cooked.Runtime.State @@ -45,23 +45,23 @@ import Polysemy.State -- | An effect that offers the ability to submit a 'TxSkel' throughout the -- modification and validation pipeline. Technically, this effect is not needed -- from a semantical perspective, as all of this could already be expressed in --- 'MockChainSubmit', however, we want this effect to exist on its own to be +-- 'Submit', however, we want this effect to exist on its own to be -- eligible to be modified by tweaks. -data MockChainValidate :: Effect where - ValidateTxSkel :: TxSkel -> MockChainValidate m (ExtendedTxSkel, SubmissionFailures, Transaction, Utxos) +data Validate :: Effect where + ValidateTxSkel :: TxSkel -> Validate m (ExtendedTxSkel, SubmissionFailures, Transaction, Utxos) -makeSem_ ''MockChainValidate +makeSem_ ''Validate -- | Generates, balances and validates a transaction from a skeleton. Returns -- the extended skeleton, generated transaction and the new produced outputs. validateTxSkel :: - (Member MockChainValidate effs) => + (Member Validate effs) => TxSkel -> Sem effs (ExtendedTxSkel, SubmissionFailures, Transaction, Utxos) -- | Same as `validateTxSkel`, but only returns the generated UTxOs validateTxSkel' :: - (Member MockChainValidate effs) => + (Member Validate effs) => TxSkel -> Sem effs Utxos validateTxSkel' = fmap (view _4) . validateTxSkel @@ -69,26 +69,26 @@ validateTxSkel' = fmap (view _4) . validateTxSkel -- | Same as `validateTxSkel'`, but only returns the list of produced -- 'Api.TxOutRef' validateTxSkelL :: - (Member MockChainValidate effs) => + (Member Validate effs) => TxSkel -> Sem effs [Api.TxOutRef] validateTxSkelL = fmap (toList . Map.keysSet) . validateTxSkel' -- | Same as `validateTxSkel`, but discards the returned transaction validateTxSkel_ :: - (Member MockChainValidate effs) => + (Member Validate effs) => TxSkel -> Sem effs () validateTxSkel_ = void . validateTxSkel --- | Interpretes the 'MockChainValidate' effects in terms of other effects, in --- particular 'MockChainSubmit'. +-- | Interpretes the 'Validate' effects in terms of other effects, in +-- particular 'Submit'. runMockChainValidate :: ( Members - '[ MockChainLog, - MockChainReadChain, - MockChainReadConf, - MockChainSubmit, + '[ Log, + Query, + Params, + Submit, Error P.Ledger.ToCardanoError, Error MockChainError, State ChainIndex, @@ -96,7 +96,7 @@ runMockChainValidate :: ] effs ) => - Sem (MockChainValidate : effs) a -> + Sem (Validate : effs) a -> Sem effs a runMockChainValidate = interpret $ \case ValidateTxSkel txSkel -> do diff --git a/src/Cooked/MockChain/Instances.hs b/src/Cooked/MockChain/Instances.hs index f7c8e36c6..078da874c 100644 --- a/src/Cooked/MockChain/Instances.hs +++ b/src/Cooked/MockChain/Instances.hs @@ -49,12 +49,12 @@ where import Cooked.Effect.Log import Cooked.Effect.Misc -import Cooked.Effect.Read.Chain -import Cooked.Effect.Read.Conf +import Cooked.Effect.Override +import Cooked.Effect.Params +import Cooked.Effect.Query import Cooked.Effect.Submission import Cooked.Effect.Time import Cooked.Effect.Validation -import Cooked.Effect.Write import Cooked.MockChain.Ltl import Cooked.MockChain.Runnable import Cooked.MockChain.Tweak @@ -72,11 +72,11 @@ import Polysemy.Writer -- | The most direct stack of effects to run a mockchain type DirectEffs = - '[ MockChainValidate, - MockChainWrite, - MockChainReadChain, - MockChainTime, - MockChainMisc, + '[ Validate, + Override, + Query, + Time, + Misc, Fail ] @@ -95,40 +95,40 @@ instance RunnableMockChain DirectEffs where . mapError MCEToCardanoError . runFailInMockChainError . runMockChainMisc - . runMockChainReadConf + . runMockChainParams . runMockChainTime - . runMockChainReadChain - . runMockChainWrite + . runMockChainQuery + . runMockChainOverride . runMockChainSubmit . runMockChainValidate . insertAt @1 - @'[ MockChainSubmit + @'[ Submit ] . insertAt @7 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, State EmulatorState, State ChainIndex, - MockChainLog, + Log, Writer MockChainJournal ] . insertAt @4 - @'[ MockChainReadConf + @'[ Params ] -- | A stack of effects aimed at being used as modifications for a -- `FullMockChain` computation type FullTweakEffs = - '[ MockChainMisc, - MockChainReadChain, - MockChainTime, - MockChainReadConf, + '[ Misc, + Query, + Time, + Params, Fail, Error P.Ledger.ToCardanoError, Error MockChainError, State EmulatorState, State ChainIndex, - MockChainLog, + Log, Writer MockChainJournal ] @@ -139,20 +139,20 @@ type FullTweak a = TypedTweak FullTweakEffs a -- addition of all the lower level effects required to interpret it. type FullEffs = '[ ModifyGlobally (UntypedTweak FullTweakEffs), - MockChainValidate, - MockChainWrite, + Validate, + Override, ModifyLocally (UntypedTweak FullTweakEffs), State [Ltl (UntypedTweak FullTweakEffs)], - MockChainMisc, - MockChainReadChain, - MockChainTime, - MockChainReadConf, + Misc, + Query, + Time, + Params, Fail, Error P.Ledger.ToCardanoError, Error MockChainError, State EmulatorState, State ChainIndex, - MockChainLog, + Log, Writer MockChainJournal, NonDet ] @@ -171,17 +171,17 @@ instance RunnableMockChain FullEffs where . runError . mapError MCEToCardanoError . runFailInMockChainError - . runMockChainReadConf + . runMockChainParams . runMockChainTime - . runMockChainReadChain + . runMockChainQuery . runMockChainMisc . evalState [] . runModifyLocally - . runMockChainWrite + . runMockChainOverride . runMockChainSubmit . runMockChainValidate . insertAt @1 - @'[ MockChainSubmit + @'[ Submit ] . reinterpretMockChainValidateWithTweak @FullTweakEffs . runModifyGlobally @@ -190,9 +190,9 @@ instance RunnableMockChain FullEffs where -- `StagedMockChain` computation type ExtendedStagedTweakEffs extraEff = '[ extraEff, - MockChainMisc, - MockChainReadChain, - MockChainTime, + Misc, + Query, + Time, Fail ] @@ -204,12 +204,12 @@ type ExtendedStagedTweak extraEff a = TypedTweak (ExtendedStagedTweakEffs extraE -- `ExtendedStagedTweakEffs` type ExtendedStagedEffs extraEff = '[ ModifyGlobally (UntypedTweak (ExtendedStagedTweakEffs extraEff)), - MockChainValidate, - MockChainWrite, + Validate, + Override, extraEff, - MockChainMisc, - MockChainReadChain, - MockChainTime, + Misc, + Query, + Time, Fail, NonDet ] @@ -234,30 +234,30 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runError . mapError MCEToCardanoError . runFailInMockChainError - . runMockChainReadConf + . runMockChainParams . runMockChainTime - . runMockChainReadChain + . runMockChainQuery . runMockChainMisc . runInterpretAlone . evalState [] . runModifyLocally - . runMockChainWrite + . runMockChainOverride . runMockChainSubmit . runMockChainValidate . insertAt @1 - @'[ MockChainSubmit + @'[ Submit ] . insertAt @10 @'[ Error P.Ledger.ToCardanoError, Error MockChainError, State EmulatorState, State ChainIndex, - MockChainLog, + Log, Writer MockChainJournal ] . reinterpretMockChainValidateWithTweak @(ExtendedStagedTweakEffs extraEff) . insertAt @8 - @'[ MockChainReadConf + @'[ Params ] . runModifyGlobally . insertAt @3 diff --git a/src/Cooked/MockChain/Runnable.hs b/src/Cooked/MockChain/Runnable.hs index 8f654b49c..5d1f21fb7 100644 --- a/src/Cooked/MockChain/Runnable.hs +++ b/src/Cooked/MockChain/Runnable.hs @@ -25,7 +25,7 @@ module Cooked.MockChain.Runnable ) where -import Cooked.Effect.Write +import Cooked.Effect.Override import Cooked.Runtime.Error import Cooked.Runtime.Journal import Cooked.Runtime.State @@ -124,7 +124,7 @@ class RunnableMockChain effs where -- | Runs a `RunnableMockChain` from an initial `MockChainConf` runMockChainFromConf :: ( RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => MockChainConf a b -> Sem effs a -> @@ -137,7 +137,7 @@ runMockChainFromConf (MockChainConf emInitState ciInitState initDist funOnResult -- | Runs a `RunnableMockChain` from an initial distribution runMockChainFromInitDist :: ( RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => InitialDistribution -> Sem effs a -> @@ -148,7 +148,7 @@ runMockChainFromInitDist initDist = -- | Same as `runMockChainFromInitDist` using the `initialDistributionTemplate` runMockChainFromInitDistTemplate :: ( RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Sem effs a -> [MockChainReturn a] @@ -157,7 +157,7 @@ runMockChainFromInitDistTemplate = runMockChainFromInitDist initialDistributionT -- | Runs a `RunnableMockChain` from a default configuration runMockChainDef :: ( RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Sem effs a -> [MockChainReturn a] diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index 5efe677ee..a773338af 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -89,7 +89,7 @@ import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Exception qualified as E import Control.Monad import Cooked.Effect.Log -import Cooked.Effect.Write +import Cooked.Effect.Override import Cooked.MockChain.Runnable import Cooked.Pretty import Cooked.Runtime.Error @@ -420,7 +420,7 @@ mustSucceedTest' runner trace = mustSucceedTest :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Sem effs a -> Test effs a a prop @@ -451,7 +451,7 @@ mustFailTest' runner trace = mustFailTest :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Sem effs a -> Test effs a a prop @@ -760,7 +760,7 @@ mustFailInPhase2Test' runner trace = mustFailInPhase2Test :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Sem effs a -> Test effs a a prop @@ -783,7 +783,7 @@ mustFailInPhase2WithMsgTest' msg runner trace = mustFailInPhase2WithMsgTest :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => String -> Sem effs a -> @@ -804,7 +804,7 @@ mustFailInPhase1Test' runner trace = mustFailInPhase1Test :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Sem effs a -> Test effs a a prop @@ -826,7 +826,7 @@ mustFailInPhase1WithMsgTest' msg runner trace = mustFailInPhase1WithMsgTest :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => String -> Sem effs a -> @@ -850,7 +850,7 @@ mustSucceedWithSizeTest' size runner trace = mustSucceedWithSizeTest :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Integer -> Sem effs a -> @@ -874,7 +874,7 @@ mustFailWithSizeTest' size runner trace = mustFailWithSizeTest :: ( IsProp prop, RunnableMockChain effs, - Member MockChainWrite effs + Member Override effs ) => Integer -> Sem effs a -> diff --git a/src/Cooked/MockChain/Tweak.hs b/src/Cooked/MockChain/Tweak.hs index 3c361db04..127b0dc59 100644 --- a/src/Cooked/MockChain/Tweak.hs +++ b/src/Cooked/MockChain/Tweak.hs @@ -99,7 +99,7 @@ withTweak :: Sem effs a withTweak = flip (there 0) --- | Reinterpretes `MockChainValidate` in itself, when the `ModifyLocally` +-- | Reinterpretes `Validate` in itself, when the `ModifyLocally` -- effect exists in the stack, applying the relevant modifications in the -- process. reinterpretMockChainValidateWithTweak :: @@ -111,9 +111,9 @@ reinterpretMockChainValidateWithTweak :: effs, Subsume tweakEffs effs ) => - Sem (MockChainValidate : effs) a -> - Sem (MockChainValidate : effs) a -reinterpretMockChainValidateWithTweak = reinterpret @MockChainValidate $ \case + Sem (Validate : effs) a -> + Sem (Validate : effs) a +reinterpretMockChainValidateWithTweak = reinterpret @Validate $ \case ValidateTxSkel skel -> do requirements <- getRequirements let sumTweak :: TypedTweak tweakEffs () = diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index ba850b117..0d006d8ae 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -16,7 +16,7 @@ import Test.Tasty.QuickCheck runSlot :: Sem - '[ MockChainTime, + '[ Time, State EmulatorState, State ChainIndex, Fail, From 5d764c3e319834611d62c8bdf928ed2b10b2d54e Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 12 Aug 2026 18:09:06 +0200 Subject: [PATCH 33/39] Drop MockChain prefix from Runtime error and journal types The Runtime types are no longer MockChain-specific (they are shared with the BlockChain backend), so drop the misleading MockChain prefix: MockChainError -> ChainError, MockChainJournal -> ChainJournal, runFailInMockChainError -> runFailInChainError. The plain Error name is avoided because it would clash with Polysemy.Error, which is used unqualified throughout. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- doc/BALANCING.md | 6 ++-- src/Cooked/Automation.hs | 2 +- src/Cooked/Automation/Balancing.hs | 10 +++--- src/Cooked/Automation/GenerateTx/Body.hs | 4 +-- .../Automation/GenerateTx/Certificate.hs | 6 ++-- src/Cooked/Automation/GenerateTx/Input.hs | 2 +- src/Cooked/Automation/GenerateTx/Mint.hs | 2 +- src/Cooked/Automation/GenerateTx/Proposal.hs | 6 ++-- .../Automation/GenerateTx/Withdrawals.hs | 2 +- src/Cooked/Automation/GenerateTx/Witness.hs | 4 +-- src/Cooked/Effect/Misc.hs | 2 +- src/Cooked/Effect/Override.hs | 2 +- src/Cooked/Effect/Query.hs | 4 +-- src/Cooked/Effect/Validation.hs | 2 +- src/Cooked/MockChain/Instances.hs | 22 ++++++------ src/Cooked/MockChain/Runnable.hs | 6 ++-- src/Cooked/MockChain/Testing.hs | 6 ++-- src/Cooked/Pretty/MockChain.hs | 4 +-- src/Cooked/Runtime/Error.hs | 16 ++++----- src/Cooked/Runtime/Journal.hs | 34 +++++++++---------- tests/Spec/Balancing.hs | 18 +++++----- tests/Spec/Slot.hs | 6 ++-- 22 files changed, 83 insertions(+), 83 deletions(-) diff --git a/doc/BALANCING.md b/doc/BALANCING.md index ae25a9368..30353e956 100644 --- a/doc/BALANCING.md +++ b/doc/BALANCING.md @@ -43,14 +43,14 @@ Our balancing function is signed as follows: ``` haskell balanceTxSkel :: - (Members '[Query, Log, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[Query, Log, Error ChainError, Error P.Ledger.ToCardanoError, Fail] effs) => TxSkel -> Sem effs ExtendedTxSkel ``` The library is built on [Polysemy] effects rather than a concrete monad, so the balancing capabilities are expressed as the effect constraints -`Members '[Query, Log, Error MockChainError, Error +`Members '[Query, Log, Error ChainError, Error P.Ledger.ToCardanoError, Fail] effs` and the result lives in `Sem effs`. This function takes a skeleton and returns an `ExtendedTxSkel`, a record bundling @@ -476,7 +476,7 @@ within this interval. The function that performs this computation is ``` haskell computeFeeAndBalance :: - (Members '[Query, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[Query, Error ChainError, Error P.Ledger.ToCardanoError, Fail] effs) => Peer -> -- the balancing user Fee -> -- lower bound of the search interval Fee -> -- upper bound of the search interval diff --git a/src/Cooked/Automation.hs b/src/Cooked/Automation.hs index 60e0f3b0f..a097c2b4b 100644 --- a/src/Cooked/Automation.hs +++ b/src/Cooked/Automation.hs @@ -50,7 +50,7 @@ import Polysemy.Fail runAutomationPipeline :: ( Members '[ Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, Log, Query, Params, diff --git a/src/Cooked/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs index 903d48aea..fc2276d14 100644 --- a/src/Cooked/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -68,7 +68,7 @@ balanceTxSkel :: '[ Query, Params, Log, - Error MockChainError, + Error ChainError, Error P.Ledger.ToCardanoError, Fail ] @@ -172,7 +172,7 @@ computeFeeAndBalance :: ( Members '[ Query, Params, - Error MockChainError, + Error ChainError, Error P.Ledger.ToCardanoError, Fail ] @@ -237,7 +237,7 @@ collateralsFromFee :: ( Members '[ Query, Params, - Error MockChainError, + Error ChainError, Error P.Ledger.ToCardanoError ] effs @@ -420,7 +420,7 @@ estimateTxSkelFee :: ( Members '[ Query, Params, - Error MockChainError, + Error ChainError, Error P.Ledger.ToCardanoError, Fail ] @@ -451,7 +451,7 @@ computeBalancedTxSkel :: ( Members '[ Query, Params, - Error MockChainError, + Error ChainError, Error P.Ledger.ToCardanoError ] effs diff --git a/src/Cooked/Automation/GenerateTx/Body.hs b/src/Cooked/Automation/GenerateTx/Body.hs index 7c60923d4..850fbde40 100644 --- a/src/Cooked/Automation/GenerateTx/Body.hs +++ b/src/Cooked/Automation/GenerateTx/Body.hs @@ -43,7 +43,7 @@ txSkelToTxBodyContent :: ( Members '[ Query, Params, - Error MockChainError, + Error ChainError, Error P.Ledger.ToCardanoError, Fail ] @@ -128,7 +128,7 @@ txSkelToTxBody :: '[ Query, Params, Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, Fail ] effs diff --git a/src/Cooked/Automation/GenerateTx/Certificate.hs b/src/Cooked/Automation/GenerateTx/Certificate.hs index 456b67af9..61d404d20 100644 --- a/src/Cooked/Automation/GenerateTx/Certificate.hs +++ b/src/Cooked/Automation/GenerateTx/Certificate.hs @@ -41,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 '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error ChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelCertificate -> Sem effs (Cardano.Certificate Cardano.ConwayEra) toCertificate txSkelCert = @@ -90,7 +90,7 @@ toCertificate txSkelCert = Conway.ConwayTxCertGov . (`Conway.ConwayResignCommitteeColdKey` SNothing) <$> toColdCredential cred toCertificateWitness :: - (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error ChainError, Error P.Ledger.ToCardanoError] effs) => TxSkelCertificate -> Sem effs (Maybe (Cardano.ScriptWitness Cardano.WitCtxStake Cardano.ConwayEra)) toCertificateWitness = @@ -104,7 +104,7 @@ toCertificateWitness = -- | Builds a 'Cardano.TxCertificates' from a list of 'TxSkelCertificate' toCertificates :: - (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError, Fail] effs) => + (Members '[Query, Params, Error ChainError, Error P.Ledger.ToCardanoError, Fail] effs) => [TxSkelCertificate] -> Sem effs (Cardano.TxCertificates Cardano.BuildTx Cardano.ConwayEra) toCertificates = diff --git a/src/Cooked/Automation/GenerateTx/Input.hs b/src/Cooked/Automation/GenerateTx/Input.hs index 432ce614b..200ae2f4d 100644 --- a/src/Cooked/Automation/GenerateTx/Input.hs +++ b/src/Cooked/Automation/GenerateTx/Input.hs @@ -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 '[Query, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Error ChainError, Error P.Ledger.ToCardanoError] effs) => (Api.TxOutRef, TxSkelRedeemer) -> Sem effs diff --git a/src/Cooked/Automation/GenerateTx/Mint.hs b/src/Cooked/Automation/GenerateTx/Mint.hs index 8f75a9289..6a9d9f141 100644 --- a/src/Cooked/Automation/GenerateTx/Mint.hs +++ b/src/Cooked/Automation/GenerateTx/Mint.hs @@ -21,7 +21,7 @@ import Polysemy.Error -- | Converts a 'TxSkelMints' into a 'Cardano.TxMintValue' toMintValue :: - (Members '[Query, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Error ChainError, 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/Automation/GenerateTx/Proposal.hs b/src/Cooked/Automation/GenerateTx/Proposal.hs index 46001966f..c413f588e 100644 --- a/src/Cooked/Automation/GenerateTx/Proposal.hs +++ b/src/Cooked/Automation/GenerateTx/Proposal.hs @@ -34,7 +34,7 @@ import Polysemy.Error -- over a Cardano parameter update toPParamsUpdate :: forall effs. - (Member (Error MockChainError) effs) => + (Member (Error ChainError) effs) => ParamChange -> Conway.PParamsUpdate Emulator.EmulatorEra -> Sem effs (Conway.PParamsUpdate Emulator.EmulatorEra) @@ -85,7 +85,7 @@ toPParamsUpdate pChange ppu = -- | Translates a given skeleton proposal into a governance action toGovAction :: - (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error ChainError, Error P.Ledger.ToCardanoError] effs) => GovernanceAction a -> StrictMaybe Conway.ScriptHash -> Sem effs (Conway.GovAction Emulator.EmulatorEra) @@ -101,7 +101,7 @@ toGovAction (TreasuryWithdrawals (Map.toList -> withdrawals)) sHash = -- | Translates a list of skeleton proposals into a proposal procedures toProposalProcedures :: - (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error ChainError, 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/Automation/GenerateTx/Withdrawals.hs b/src/Cooked/Automation/GenerateTx/Withdrawals.hs index 82b91e8d7..bf5ec0a37 100644 --- a/src/Cooked/Automation/GenerateTx/Withdrawals.hs +++ b/src/Cooked/Automation/GenerateTx/Withdrawals.hs @@ -20,7 +20,7 @@ import Polysemy.Error -- | Takes a 'TxSkelWithdrawals' and transforms it into a 'Cardano.TxWithdrawals' toWithdrawals :: - (Members '[Query, Params, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Params, Error ChainError, 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/Automation/GenerateTx/Witness.hs b/src/Cooked/Automation/GenerateTx/Witness.hs index faf94f9c0..86bfb97d4 100644 --- a/src/Cooked/Automation/GenerateTx/Witness.hs +++ b/src/Cooked/Automation/GenerateTx/Witness.hs @@ -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 '[Query, Error MockChainError, Error P.Ledger.ToCardanoError] effs) => + (Members '[Query, Error ChainError, 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 '[Query, Error MockChainError, Error P.Ledger.ToCardanoError] effs, + ( Members '[Query, Error ChainError, Error P.Ledger.ToCardanoError] effs, ToVScript a ) => a -> diff --git a/src/Cooked/Effect/Misc.hs b/src/Cooked/Effect/Misc.hs index 6f132b23c..ea54f520a 100644 --- a/src/Cooked/Effect/Misc.hs +++ b/src/Cooked/Effect/Misc.hs @@ -108,7 +108,7 @@ assert' = assertS "Assertion" -- 3 actions only update the state, which is only used at the end of the run. runMockChainMisc :: forall effs a. - (Member (Writer MockChainJournal) effs) => + (Member (Writer ChainJournal) effs) => Sem (Misc : effs) a -> Sem effs a runMockChainMisc = interpret $ \case diff --git a/src/Cooked/Effect/Override.hs b/src/Cooked/Effect/Override.hs index def48cd09..567607825 100644 --- a/src/Cooked/Effect/Override.hs +++ b/src/Cooked/Effect/Override.hs @@ -57,7 +57,7 @@ runMockChainOverride :: '[ State EmulatorState, State ChainIndex, Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, Log, Query, Params diff --git a/src/Cooked/Effect/Query.hs b/src/Cooked/Effect/Query.hs index 19128a8ce..b0b96a254 100644 --- a/src/Cooked/Effect/Query.hs +++ b/src/Cooked/Effect/Query.hs @@ -243,7 +243,7 @@ runMockChainQuery :: '[ State EmulatorState, State ChainIndex, Error P.Ledger.ToCardanoError, - Error MockChainError + Error ChainError ] effs ) => @@ -290,7 +290,7 @@ runBlockChainQuery :: Error Cardano.EraMismatch, Error Cardano.AcquiringFailure, Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, Reader Cardano.LocalNodeConnectInfo, State ChainIndex ] diff --git a/src/Cooked/Effect/Validation.hs b/src/Cooked/Effect/Validation.hs index 5cb19ade5..adadfe964 100644 --- a/src/Cooked/Effect/Validation.hs +++ b/src/Cooked/Effect/Validation.hs @@ -90,7 +90,7 @@ runMockChainValidate :: Params, Submit, Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, State ChainIndex, Fail ] diff --git a/src/Cooked/MockChain/Instances.hs b/src/Cooked/MockChain/Instances.hs index 078da874c..5bf0645c0 100644 --- a/src/Cooked/MockChain/Instances.hs +++ b/src/Cooked/MockChain/Instances.hs @@ -93,7 +93,7 @@ instance RunnableMockChain DirectEffs where . runState emInit . runError . mapError MCEToCardanoError - . runFailInMockChainError + . runFailInChainError . runMockChainMisc . runMockChainParams . runMockChainTime @@ -106,11 +106,11 @@ instance RunnableMockChain DirectEffs where ] . insertAt @7 @'[ Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, State EmulatorState, State ChainIndex, Log, - Writer MockChainJournal + Writer ChainJournal ] . insertAt @4 @'[ Params @@ -125,11 +125,11 @@ type FullTweakEffs = Params, Fail, Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, State EmulatorState, State ChainIndex, Log, - Writer MockChainJournal + Writer ChainJournal ] -- | A tweak computation based on the `FullTweakEffs` stack of effects @@ -149,11 +149,11 @@ type FullEffs = Params, Fail, Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, State EmulatorState, State ChainIndex, Log, - Writer MockChainJournal, + Writer ChainJournal, NonDet ] @@ -170,7 +170,7 @@ instance RunnableMockChain FullEffs where . runState emInit . runError . mapError MCEToCardanoError - . runFailInMockChainError + . runFailInChainError . runMockChainParams . runMockChainTime . runMockChainQuery @@ -233,7 +233,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runState emInit . runError . mapError MCEToCardanoError - . runFailInMockChainError + . runFailInChainError . runMockChainParams . runMockChainTime . runMockChainQuery @@ -249,11 +249,11 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr ] . insertAt @10 @'[ Error P.Ledger.ToCardanoError, - Error MockChainError, + Error ChainError, State EmulatorState, State ChainIndex, Log, - Writer MockChainJournal + Writer ChainJournal ] . reinterpretMockChainValidateWithTweak @(ExtendedStagedTweakEffs extraEff) . insertAt @8 diff --git a/src/Cooked/MockChain/Runnable.hs b/src/Cooked/MockChain/Runnable.hs index 5d1f21fb7..978ff6b8b 100644 --- a/src/Cooked/MockChain/Runnable.hs +++ b/src/Cooked/MockChain/Runnable.hs @@ -69,20 +69,20 @@ distributionFromList = foldl' (\x (user, values) -> x <> map (receives user . Va -- | Raw return type of running a mockchain type RawMockChainReturn a = - (MockChainJournal, (ChainIndex, (EmulatorState, Either MockChainError a))) + (ChainJournal, (ChainIndex, (EmulatorState, Either ChainError a))) -- | The returned type when running a mockchain. This is both a reorganizing and -- filtering of the natural returned type `RawMockChainReturn`. data MockChainReturn a where MockChainReturn :: { -- | The value returned by the computation, or an error - mcrValue :: Either MockChainError a, + mcrValue :: Either ChainError a, -- | The outputs at the end of the run mcrOutputs :: Map Api.TxOutRef (TxSkelOut, Bool), -- | The 'UtxoState' at the end of the run mcrUtxoState :: UtxoState, -- | The final journal emitted during the run - mcrJournal :: MockChainJournal + mcrJournal :: ChainJournal } -> MockChainReturn a deriving (Functor) diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index a773338af..43a32c0fc 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -274,7 +274,7 @@ assertSameSets l r = --} -- | Type of properties over failures -type FailureProp prop = PrettyCookedOpts -> [MockChainLogEntry] -> MockChainError -> UtxoState -> prop +type FailureProp prop = PrettyCookedOpts -> [MockChainLogEntry] -> ChainError -> UtxoState -> prop -- | Type of properties over successes type SuccessProp a prop = PrettyCookedOpts -> [MockChainLogEntry] -> a -> UtxoState -> prop @@ -335,7 +335,7 @@ testToProp Test {..} = let results = testRunner testInitEmulatorState testInitChainIndex testInitDist testTrace in testSizeProp (toInteger (length results)) .&&. testAll - ( \ret@(MockChainReturn outcome _ state (MockChainJournal mcLog names _ assertions)) -> + ( \ret@(MockChainReturn outcome _ state (ChainJournal mcLog names _ assertions)) -> let pcOpts = addHashNames names testPrettyOpts in testConjoin [ testConjoin $ (\(msg, b) -> testBoolMsg (renderString id (msg pcOpts)) b) <$> assertions, @@ -553,7 +553,7 @@ withFailureProp test failureProp = withErrorProp :: (IsProp prop) => Test effs a b prop -> - (MockChainError -> prop) -> + (ChainError -> prop) -> Test effs a b prop withErrorProp test errorProp = withFailureProp test (\_ _ err _ -> errorProp err) diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index c91d448d5..08240e00c 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -40,7 +40,7 @@ instance (Show a) => PrettyCooked [MockChainReturn a] where (PP.align . prettyCookedOpt opts <$> outcomes) instance (Show a) => PrettyCooked (MockChainReturn a) where - prettyCookedOpt opts' (MockChainReturn res outputs (UtxoState available consumed) (MockChainJournal entries ((`addHashNames` opts') -> opts) noteBook assertions)) = + prettyCookedOpt opts' (MockChainReturn res outputs (UtxoState available consumed) (ChainJournal entries ((`addHashNames` opts') -> opts) noteBook assertions)) = PP.vsep $ [ prettyItemize opts "📔 Notes:" "-" $ ($ opts) <$> noteBook | pcOptPrintNotebook opts && not (null noteBook) @@ -85,7 +85,7 @@ instance PrettyCooked BalancingError where "Resulting minimal collateral value was" <+> prettyCookedOpt opts colVal ] -instance PrettyCooked MockChainError where +instance PrettyCooked ChainError where prettyCookedOpt opts (MCEExUnitsFailures failures) = prettyItemize opts "Execution units failures:" "-" (PP.viaShow <$> Map.elems failures :: [DocCooked]) prettyCookedOpt opts (MCESubmissionFailures failures) = diff --git a/src/Cooked/Runtime/Error.hs b/src/Cooked/Runtime/Error.hs index 0800d1b96..54b1125fc 100644 --- a/src/Cooked/Runtime/Error.hs +++ b/src/Cooked/Runtime/Error.hs @@ -2,10 +2,10 @@ module Cooked.Runtime.Error ( -- * Mockchain errors BalancingError (..), - MockChainError (..), + ChainError (..), - -- * Interpreting Fail into @Error MockChainError@ - runFailInMockChainError, + -- * Interpreting Fail into @Error ChainError@ + runFailInChainError, ) where @@ -37,7 +37,7 @@ data BalancingError deriving (Show, Eq) -- | Errors that can be produced by the blockchain -data MockChainError +data ChainError = -- | Failures occurring while computing execution units MCEExUnitsFailures ExUnitsFailures | -- | Failures occurring while submitting the transaction for validation @@ -62,11 +62,11 @@ data MockChainError MCEFailure String deriving (Show, Eq) --- | Interpreting failures in terms of `MockChainError` -runFailInMockChainError :: +-- | Interpreting failures in terms of `ChainError` +runFailInChainError :: forall effs a. - (Member (Error MockChainError) effs) => + (Member (Error ChainError) effs) => Sem (Fail : effs) a -> Sem effs a -runFailInMockChainError = interpret $ +runFailInChainError = interpret $ \(Fail s) -> throw $ MCEFailure s diff --git a/src/Cooked/Runtime/Journal.hs b/src/Cooked/Runtime/Journal.hs index 182f4ecb9..8e9161ad6 100644 --- a/src/Cooked/Runtime/Journal.hs +++ b/src/Cooked/Runtime/Journal.hs @@ -1,6 +1,6 @@ -- | This module exposes the various events emitted during a mockchain run. module Cooked.Runtime.Journal - ( MockChainJournal (..), + ( ChainJournal (..), fromLogEntry, fromAlias, fromNote, @@ -17,8 +17,8 @@ import PlutusLedgerApi.V3 qualified as Api -- | This represents the writable elements that can be emitted throughout a -- mockchain run. -data MockChainJournal where - MockChainJournal :: +data ChainJournal where + ChainJournal :: { -- | Log entries generated by cooked-validators mcbLog :: [MockChainLogEntry], -- | Aliases stored by the user @@ -30,27 +30,27 @@ data MockChainJournal where -- messages to display in case of failure mcbAssertions :: [(PrettyCookedOpts -> DocCooked, Bool)] } -> - MockChainJournal + ChainJournal -instance Semigroup MockChainJournal where - MockChainJournal l a n p <> MockChainJournal l' a' n' p' = - MockChainJournal (l <> l') (a <> a') (n <> n') (p <> p') +instance Semigroup ChainJournal where + ChainJournal l a n p <> ChainJournal l' a' n' p' = + ChainJournal (l <> l') (a <> a') (n <> n') (p <> p') -instance Monoid MockChainJournal where - mempty = MockChainJournal mempty mempty mempty mempty +instance Monoid ChainJournal where + mempty = ChainJournal mempty mempty mempty mempty --- | Build a `MockChainJournal` from a single log entry -fromLogEntry :: MockChainLogEntry -> MockChainJournal +-- | Build a `ChainJournal` from a single log entry +fromLogEntry :: MockChainLogEntry -> ChainJournal fromLogEntry entry = mempty {mcbLog = [entry]} --- | Build a `MockChainJournal` from a single alias -fromAlias :: String -> Api.BuiltinByteString -> MockChainJournal +-- | Build a `ChainJournal` from a single alias +fromAlias :: String -> Api.BuiltinByteString -> ChainJournal fromAlias s hash = mempty {mcbAliases = Map.singleton hash s} --- | Build a `MockChainJournal` from a single note -fromNote :: (PrettyCookedOpts -> DocCooked) -> MockChainJournal +-- | Build a `ChainJournal` from a single note +fromNote :: (PrettyCookedOpts -> DocCooked) -> ChainJournal fromNote s = mempty {mcbNotes = [s]} --- | Build a `MockChainJournal` from a single assertion and error message -fromAssert :: (PrettyCookedOpts -> DocCooked) -> Bool -> MockChainJournal +-- | Build a `ChainJournal` from a single assertion and error message +fromAssert :: (PrettyCookedOpts -> DocCooked) -> Bool -> ChainJournal fromAssert s p = mempty {mcbAssertions = [(s, p)]} diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index 3902c14e4..a2a11aff2 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -208,40 +208,40 @@ testBalancingSucceedsWith msg props run = `withInitDist` initialDistributionBalancing `withResultProp` \res -> testConjoin (($ res) <$> props) -failsAtBalancingWith :: Api.Value -> Wallet -> MockChainError -> Assertion +failsAtBalancingWith :: Api.Value -> Wallet -> ChainError -> Assertion failsAtBalancingWith val' wal' (MCEBalancingError (NotEnoughFund wal val)) = testBool $ val' == val && Script.toPubKeyHash wal' == Script.toPubKeyHash wal failsAtBalancingWith _ _ _ = testBool False -failsAtBalancing :: MockChainError -> Assertion +failsAtBalancing :: ChainError -> Assertion failsAtBalancing (MCEBalancingError (NotEnoughFund {})) = testBool True failsAtBalancing (MCEBalancingError (NotEnoughFundForExtraMinAda {})) = testBool True failsAtBalancing _ = testBool False -failsWithTooLittleFee :: MockChainError -> Assertion +failsWithTooLittleFee :: ChainError -> Assertion failsWithTooLittleFee (MCESubmissionFailures failures) = testBool $ any (isInfixOf "FeeTooSmallUTxO" . show) failures failsWithTooLittleFee _ = testBool False -failsWithValueNotConserved :: MockChainError -> Assertion +failsWithValueNotConserved :: ChainError -> Assertion failsWithValueNotConserved (MCESubmissionFailures failures) = testBool $ any (isInfixOf "ValueNotConserved" . show) failures failsWithValueNotConserved _ = testBool False -failsWithEmptyTxIns :: MockChainError -> Assertion +failsWithEmptyTxIns :: ChainError -> Assertion failsWithEmptyTxIns (MCESubmissionFailures failures) = testBool $ any (isInfixOf "InputSetEmptyUTxO" . show) failures failsWithEmptyTxIns _ = testBool False -failsAtCollateralsWith :: Integer -> MockChainError -> Assertion +failsAtCollateralsWith :: Integer -> ChainError -> Assertion failsAtCollateralsWith fee' (MCEBalancingError (NoSuitableCollateral fee percentage val)) = testBool $ fee == fee' && val == Script.lovelace (1 + (fee * percentage) `div` 100) failsAtCollateralsWith _ _ = testBool False -failsAtCollaterals :: MockChainError -> Assertion +failsAtCollaterals :: ChainError -> Assertion failsAtCollaterals (MCEBalancingError (NoSuitableCollateral {})) = testBool True failsAtCollaterals _ = testBool False -failsLackOfCollateralWallet :: MockChainError -> Assertion +failsLackOfCollateralWallet :: ChainError -> Assertion failsLackOfCollateralWallet (MCEBalancingError MissingBalancingUser) = testBool True failsLackOfCollateralWallet _ = testBool False -testBalancingFailsWith :: (Show a) => String -> (MockChainError -> Assertion) -> FullMockChain a -> TestTree +testBalancingFailsWith :: (Show a) => String -> (ChainError -> Assertion) -> FullMockChain a -> TestTree testBalancingFailsWith msg p smc = testCooked msg $ mustFailTest smc diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index 0d006d8ae..ef1a3e7f4 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -21,15 +21,15 @@ runSlot :: State ChainIndex, Fail, Error P.Ledger.ToCardanoError, - Error MockChainError + Error ChainError ] a -> - Either MockChainError a + Either ChainError a runSlot = run . runError . mapError MCEToCardanoError - . runFailInMockChainError + . runFailInChainError . evalState def . evalState def . runMockChainTime From b86edc44742793edbffbb6424ab5000fc6bd841f Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 13 Aug 2026 00:22:15 +0200 Subject: [PATCH 34/39] some more refactoring and renaming, resolving circular dependencies and implementing log in IO --- cooked-validators.cabal | 3 +- .../Automation/AutoFilling/Constitution.hs | 3 +- src/Cooked/Automation/AutoFilling/MinAda.hs | 3 +- .../AutoFilling/ReferenceScripts.hs | 3 +- .../Automation/AutoFilling/Withdrawals.hs | 3 +- src/Cooked/Automation/Balancing.hs | 19 ++-- .../Automation/GenerateTx/Certificate.hs | 2 +- src/Cooked/Automation/GenerateTx/Input.hs | 4 +- src/Cooked/Automation/GenerateTx/Proposal.hs | 8 +- src/Cooked/Automation/GenerateTx/Witness.hs | 2 +- src/Cooked/BlockChain/Instances.hs | 38 +++++++- src/Cooked/Effect/Log.hs | 93 +++++++------------ src/Cooked/Effect/Override.hs | 30 +++--- src/Cooked/Effect/Query.hs | 4 +- src/Cooked/Effect/Validation.hs | 19 ++-- src/Cooked/MockChain.hs | 3 +- .../MockChain/{Runnable.hs => Config.hs} | 64 +------------ src/Cooked/MockChain/Instances.hs | 14 +-- src/Cooked/MockChain/Run.hs | 63 +++++++++++++ src/Cooked/MockChain/Testing.hs | 22 ++--- src/Cooked/Pretty/MockChain.hs | 53 ++++++----- src/Cooked/Runtime/Error.hs | 22 ++--- src/Cooked/Runtime/Journal.hs | 57 +++++++++++- tests/Spec/Balancing.hs | 18 ++-- tests/Spec/ProposingScript.hs | 20 ++-- tests/Spec/ReferenceScripts.hs | 10 +- tests/Spec/Slot.hs | 2 +- tests/Spec/Withdrawals.hs | 8 +- 28 files changed, 330 insertions(+), 260 deletions(-) rename src/Cooked/MockChain/{Runnable.hs => Config.hs} (66%) create mode 100644 src/Cooked/MockChain/Run.hs diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 94c935ad7..4c8ba75d7 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -52,9 +52,10 @@ library Cooked.Effect.Time Cooked.Effect.Validation Cooked.MockChain + Cooked.MockChain.Config Cooked.MockChain.Instances Cooked.MockChain.Ltl - Cooked.MockChain.Runnable + Cooked.MockChain.Run Cooked.MockChain.Testing Cooked.MockChain.Tweak Cooked.Pretty diff --git a/src/Cooked/Automation/AutoFilling/Constitution.hs b/src/Cooked/Automation/AutoFilling/Constitution.hs index 855e95d48..cba107a90 100644 --- a/src/Cooked/Automation/AutoFilling/Constitution.hs +++ b/src/Cooked/Automation/AutoFilling/Constitution.hs @@ -10,6 +10,7 @@ import Control.Monad import Control.Monad.Extra import Cooked.Effect.Log import Cooked.Effect.Query +import Cooked.Runtime.Journal import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -38,7 +39,7 @@ autoFillConstitution = do ( \constitutionScript -> traverseTweak (txSkelProposalsL % traversed) $ \prop -> do when (isn't txSkelProposalConstitutionAT prop) $ logEvent $ - MCLogAutoFilledConstitution $ + CLogAutoFilledConstitution $ Script.toScriptHash constitutionScript return (fillConstitutionWhenEmpty constitutionScript prop) ) diff --git a/src/Cooked/Automation/AutoFilling/MinAda.hs b/src/Cooked/Automation/AutoFilling/MinAda.hs index 9e6327bda..48e1fbb79 100644 --- a/src/Cooked/Automation/AutoFilling/MinAda.hs +++ b/src/Cooked/Automation/AutoFilling/MinAda.hs @@ -15,6 +15,7 @@ import Cooked.Automation.GenerateTx.Output import Cooked.Effect.Log import Cooked.Effect.Params import Cooked.Effect.Query +import Cooked.Runtime.Journal import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -55,7 +56,7 @@ toTxSkelOutWithMinAda txSkelOut = do txSkelOut' <- go txSkelOut let originalAda = view (txSkelOutValueL % valueLovelaceL) txSkelOut updatedAda = view (txSkelOutValueL % valueLovelaceL) txSkelOut' - when (originalAda /= updatedAda) $ logEvent $ MCLogAdjustedTxSkelOut txSkelOut updatedAda + when (originalAda /= updatedAda) $ logEvent $ CLogAdjustedTxSkelOut txSkelOut updatedAda return txSkelOut' where go :: TxSkelOut -> Sem effs TxSkelOut diff --git a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs index 5bf37d7e6..ec5d4b850 100644 --- a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs +++ b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs @@ -10,6 +10,7 @@ where import Control.Monad import Cooked.Effect.Log import Cooked.Effect.Query +import Cooked.Runtime.Journal import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Query @@ -44,7 +45,7 @@ updateRedeemedScript (return rs) -- If a reference input is found, we assign it and log the event ( \oRef -> do - logEvent $ MCLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash vScript) + logEvent $ CLogAddedReferenceScript txSkelRed oRef (Script.toScriptHash vScript) return $ over userRedeemerAT (fillReferenceInput oRef) rs ) $ case oRefsInInputs of diff --git a/src/Cooked/Automation/AutoFilling/Withdrawals.hs b/src/Cooked/Automation/AutoFilling/Withdrawals.hs index 76421e3d1..777091e4c 100644 --- a/src/Cooked/Automation/AutoFilling/Withdrawals.hs +++ b/src/Cooked/Automation/AutoFilling/Withdrawals.hs @@ -7,6 +7,7 @@ where import Cooked.Effect.Log import Cooked.Effect.Query +import Cooked.Runtime.Journal import Cooked.Skeleton import Cooked.Tweak.Common import Cooked.Tweak.Update @@ -30,7 +31,7 @@ autoFillWithdrawalAmounts = do Just reward | isn't withdrawalAmountAT withdrawal -> do let newWithdrawal = fillAmount reward withdrawal logEvent $ - MCLogAutoFilledWithdrawalAmount + CLogAutoFilledWithdrawalAmount (view (withdrawalUserL % to Script.toCredential) newWithdrawal) reward return newWithdrawal diff --git a/src/Cooked/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs index fc2276d14..65bffffc5 100644 --- a/src/Cooked/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -21,6 +21,7 @@ import Cooked.Effect.Log import Cooked.Effect.Params import Cooked.Effect.Query import Cooked.Runtime.Error +import Cooked.Runtime.Journal import Cooked.Skeleton import Cooked.Utilities.Aliases import Data.ByteString qualified as BS @@ -82,7 +83,7 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- with the @BalancingUtxosFromBalancingUser@ policy balancingUser <- case txSkelOptBalancingPolicy txSkelOpts of BalanceWithFirstSignatory -> case txSkelSignatories of - [] -> throw $ MCEBalancingError MissingBalancingUser + [] -> throw $ CEBalancingError MissingBalancingUser bw : _ -> return $ Just $ UserPubKey bw BalanceWith bUser -> return $ Just $ UserPubKey bUser DoNotBalance -> return Nothing @@ -102,9 +103,9 @@ balanceTxSkel skelUnbal@TxSkel {..} = do mCollaterals <- do case (nbOfScripts == 0, txSkelOptCollateralUtxos txSkelOpts) of -- No script involved, but manual collateral UTxOs provided - (True, CollateralUtxosFromSet utxos _) -> logEvent (MCLogUnusedCollaterals $ Right utxos) >> return Nothing + (True, CollateralUtxosFromSet utxos _) -> logEvent (CLogUnusedCollaterals $ Right utxos) >> return Nothing -- No script involved, but manual collateral user provided - (True, CollateralUtxosFromUser cUser) -> logEvent (MCLogUnusedCollaterals $ Left $ UserPubKey cUser) >> return Nothing + (True, CollateralUtxosFromUser cUser) -> logEvent (CLogUnusedCollaterals $ Left $ UserPubKey cUser) >> return Nothing -- No script involved, and no particular collateral option provided (True, CollateralUtxosFromBalancingUser) -> return Nothing -- Some scripts involved, and a specific set of UTxOs, alongside a @@ -117,7 +118,7 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- 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 + Nothing -> throw $ CEBalancingError MissingBalancingUser -- If a balancing wallet exists, we use it as collateral user Just bUser -> Just . (,bUser) <$> getTxOutRefs (utxosAtSearch bUser ensureOnlyValueOutputs) @@ -164,7 +165,7 @@ balanceTxSkel skelUnbal@TxSkel {..} = do where filterAndWarn f s l | (ok, toInteger . length -> koLength) <- Map.partitionWithKey f l = - unless (koLength == 0) (logEvent $ MCLogDiscardedUtxos koLength s) >> return ok + unless (koLength == 0) (logEvent $ CLogDiscardedUtxos koLength s) >> return ok -- | Computes optimal fee for a given skeleton and balances it around those fees. -- This uses a dichotomic search for an optimal "balanceable around" fee. @@ -203,7 +204,7 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske | 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 + | minFee == maxFee -> throw $ CEBalancingError $ NotEnoughFundForProperFee balancingUser -- Current fee is insufficient, we look on the right (strictly) | newFee > fee -> computeFeeAndBalance balancingUser newFee maxFee balancingUtxos mCollaterals skel -- Current fee is sufficient, but the set of balancing utxos cannot @@ -224,7 +225,7 @@ computeFeeAndBalance balancingUser minFee maxFee balancingUtxos mCollaterals ske -- If it fails, and the remaining fee interval is not reduced to the -- current fee attempt, we can still hope for a solution by trying with -- smaller fee. - MCEBalancingError {} | fee > minFee -> computeFeeAndBalance balancingUser minFee (fee - 1) balancingUtxos mCollaterals skel + CEBalancingError {} | fee > minFee -> computeFeeAndBalance balancingUser minFee (fee - 1) balancingUtxos mCollaterals skel -- Otherwise, the whole balancing process fails and we spread the error: -- the skeleton was not balanceable. err -> throw err @@ -271,7 +272,7 @@ collateralsFromFee fee (Just (collateralIns, returnCollateralUser)) = do case reachedValue of -- If no value was reached, the input UTxOs are insufficient to provide -- the necessary collaterals, and thus an error is raised - Nothing -> throw $ MCEBalancingError $ NoSuitableCollateral fee percentage totalCollateral + Nothing -> throw $ CEBalancingError $ NoSuitableCollateral fee percentage totalCollateral -- If a value was reached, we return it alongside the return collaterals Just (oRefs, returnOutput) -> return $ Just (Set.fromList oRefs, returnOutput) @@ -512,7 +513,7 @@ computeBalancedTxSkel balancingUser balancingUtxos txSkel@TxSkel {..} (Script.lo let totalValue = foldOf (traversed % txSkelOutValueL) balancingUtxos difference = snd $ Api.split $ missingLeft <> PlutusTx.negate totalValue throw $ - MCEBalancingError $ + CEBalancingError $ if difference == mempty then NotEnoughFundForExtraMinAda balancingUser else NotEnoughFund balancingUser difference diff --git a/src/Cooked/Automation/GenerateTx/Certificate.hs b/src/Cooked/Automation/GenerateTx/Certificate.hs index 61d404d20..fdf00bf57 100644 --- a/src/Cooked/Automation/GenerateTx/Certificate.hs +++ b/src/Cooked/Automation/GenerateTx/Certificate.hs @@ -81,7 +81,7 @@ toCertificate txSkelCert = case Cardano.slotToEpoch (fromIntegral slot) eeh of -- TODO: we could have a dedicated error for this case if the -- can occur at several places in the codebase - Left err -> throw $ MCEFailure $ "Too far away in the future: " <> show err + Left err -> throw $ CEFailure $ "Too far away in the future: " <> show err Right (epoch, _, _) -> return epoch ) TxSkelCertificate (Script.toCredential -> coldCred) (CommitteeRegisterHot hotCred) -> diff --git a/src/Cooked/Automation/GenerateTx/Input.hs b/src/Cooked/Automation/GenerateTx/Input.hs index 200ae2f4d..a3633d8d1 100644 --- a/src/Cooked/Automation/GenerateTx/Input.hs +++ b/src/Cooked/Automation/GenerateTx/Input.hs @@ -29,7 +29,7 @@ toTxInAndWitness (txOutRef, txSkelRedeemer) = do 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 + SomeTxSkelOutDatumHash hash -> throw $ CESpendingHashOnlyDatum txOutRef hash witness <- case txSkelOutOwner of UserPubKey _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending UserScript script -> do @@ -46,5 +46,5 @@ toTxInAndWitness (txOutRef, txSkelRedeemer) = do Just vScript | Script.toScriptHash vScript == sHash -> Cardano.ScriptWitness Cardano.ScriptWitnessForSpending <$> toScriptWitness vScript txSkelRedeemer scriptDatum - _ -> throw $ MCESpendingHashOnlyScript txOutRef sHash + _ -> throw $ CESpendingHashOnlyScript txOutRef sHash (,Cardano.BuildTxWith witness) <$> fromEither (P.Ledger.toCardanoTxIn txOutRef) diff --git a/src/Cooked/Automation/GenerateTx/Proposal.hs b/src/Cooked/Automation/GenerateTx/Proposal.hs index c413f588e..b2be4aa94 100644 --- a/src/Cooked/Automation/GenerateTx/Proposal.hs +++ b/src/Cooked/Automation/GenerateTx/Proposal.hs @@ -62,7 +62,7 @@ toPParamsUpdate pChange ppu = TreasuryCut q -> setL Conway.ppuTauL $ toBR q MinPoolCost n -> setL Conway.ppuMinPoolCostL $ fromIntegral n CoinsPerUTxOByte n -> setL Conway.ppuCoinsPerUTxOByteL $ Conway.CoinPerByte $ fromIntegral n - CostModels _pv1 _pv2 _pv3 -> throw $ MCEUnsupportedFeature "CostModels" + CostModels _pv1 _pv2 _pv3 -> throw $ CEUnsupportedFeature "CostModels" Prices q r -> setL Conway.ppuPricesL $ Cardano.Prices (toBR q) (toBR r) MaxTxExUnits n m -> setL Conway.ppuMaxTxExUnitsL $ Cardano.ExUnits (fromIntegral n) (fromIntegral m) MaxBlockExUnits n m -> setL Conway.ppuMaxBlockExUnitsL $ Cardano.ExUnits (fromIntegral n) (fromIntegral m) @@ -90,9 +90,9 @@ toGovAction :: StrictMaybe Conway.ScriptHash -> Sem effs (Conway.GovAction Emulator.EmulatorEra) toGovAction NoConfidence _ = return $ Conway.NoConfidence SNothing -toGovAction UpdateCommittee {} _ = throw $ MCEUnsupportedFeature "UpdateCommittee" -toGovAction NewConstitution {} _ = throw $ MCEUnsupportedFeature "TxGovActionNewConstitution" -toGovAction HardForkInitiation {} _ = throw $ MCEUnsupportedFeature "TxGovActionHardForkInitiation" +toGovAction UpdateCommittee {} _ = throw $ CEUnsupportedFeature "UpdateCommittee" +toGovAction NewConstitution {} _ = throw $ CEUnsupportedFeature "TxGovActionNewConstitution" +toGovAction HardForkInitiation {} _ = throw $ CEUnsupportedFeature "TxGovActionHardForkInitiation" toGovAction (ParameterChange changes) sHash = do ppu <- foldM (flip toPParamsUpdate) (Conway.PParamsUpdate Cardano.emptyPParamsStrictMaybe) changes return $ Conway.ParameterChange SNothing ppu sHash diff --git a/src/Cooked/Automation/GenerateTx/Witness.hs b/src/Cooked/Automation/GenerateTx/Witness.hs index 86bfb97d4..154330357 100644 --- a/src/Cooked/Automation/GenerateTx/Witness.hs +++ b/src/Cooked/Automation/GenerateTx/Witness.hs @@ -33,7 +33,7 @@ toPlutusScriptOrReferenceInput (Script.toScriptHash -> scriptHash) (Just scriptO | scriptHash == scriptHash' -> do s <- fromEither $ P.Ledger.toCardanoTxIn scriptOutRef return $ Cardano.PReferenceScript s - _ -> throw $ MCEWrongReferenceScriptError scriptOutRef scriptHash mScriptHash + _ -> throw $ CEWrongReferenceScriptError scriptOutRef scriptHash mScriptHash -- | Translates a script with its associated redeemer and datum to a script -- witness. Note on the usage of 'P.Ledger.zeroExecutionUnits': at this stage of diff --git a/src/Cooked/BlockChain/Instances.hs b/src/Cooked/BlockChain/Instances.hs index 4c7a450f3..187a51fbc 100644 --- a/src/Cooked/BlockChain/Instances.hs +++ b/src/Cooked/BlockChain/Instances.hs @@ -1,4 +1,40 @@ -- | This module exposes the concrete instances to run a blockchain against a -- real node backend, mirroring 'Cooked.MockChain.Instances' which targets the -- emulated chain. -module Cooked.BlockChain.Instances () where +module Cooked.BlockChain.Instances + ( FullBlockChainEffs, + FullBlockChain, + ) +where + +import Cardano.Api qualified as Cardano +import Cooked.Effect +import Cooked.Runtime +import Ledger qualified as P.Ledger +import Polysemy +import Polysemy.Error +import Polysemy.Fail +import Polysemy.Reader +import Polysemy.State + +-- | The most direct stack of effects to run a mockchain +type FullBlockChainEffs = + '[ Validate, + Query, + Time, + Misc, + Fail, + Params, + Error Cardano.UnsupportedNtcVersionError, + Error Cardano.EraMismatch, + Error Cardano.AcquiringFailure, + Error ChainError, + Error P.Ledger.ToCardanoError, + Error Cardano.PastHorizonException, + Reader Cardano.LocalNodeConnectInfo, + State ChainIndex, + Embed IO + ] + +-- | A mockchain computation built on top of the `DirectEffs` stack of effects +type FullBlockChain a = Sem FullBlockChainEffs a diff --git a/src/Cooked/Effect/Log.hs b/src/Cooked/Effect/Log.hs index e3ea8b6d2..2a379751d 100644 --- a/src/Cooked/Effect/Log.hs +++ b/src/Cooked/Effect/Log.hs @@ -7,85 +7,56 @@ -- solely be used to track internal events. To trace additional elements from a -- user's perspective, use `Cooked.Effect.Misc.note` instead. module Cooked.Effect.Log - ( -- * Logging events - TxValidity (..), - MockChainLogEntry (..), - - -- * Logging effect + ( -- * Logging effect Log, runMockChainLog, + runBlockChainLog, -- * Logging primitive logEvent, ) where -import Cooked.Skeleton -import Cooked.Utilities.Aliases -import Plutus.Script.Utils.Scripts qualified as Script -import PlutusLedgerApi.V3 qualified as Api +import Cooked.Pretty.Class +import Cooked.Pretty.MockChain () +import Cooked.Pretty.Options +import Cooked.Pretty.Skeleton +import Cooked.Runtime.Journal +import Cooked.Runtime.State import Polysemy +import Polysemy.State import Polysemy.Writer --- | The validity of a transaction -data TxValidity - = -- | The transaction is valid, we store the number of inputs and outputs - Valid Int Int - | -- | The transaction is invalid in phase 1 (no ledger change) - InvalidPhase1 - | -- | The transaction is invalid in phase 2, we store the number of collateral - -- inputs and return collateral outputs - InvalidPhase2 Int Int - deriving (Show) - --- | Events logged when processing transaction skeletons -data MockChainLogEntry - = -- | Logging a Skeleton as it is submitted by the user. - MCLogSubmittedTxSkel TxSkel - | -- | Logging a Skeleton as it has been adjusted by the balancing mechanism, - -- alongside fee, and possible collateral utxos and return collateral user. - MCLogAdjustedTxSkel TxSkel Fee (Maybe Collaterals) - | -- | Logging the production of a new transaction, with its ID as well as its - -- validity. - MCLogNewTx Api.TxId TxValidity - | -- | Logging the fact that utxos provided by the user for balancing have to be - -- discarded for a specific reason. - MCLogDiscardedUtxos Integer String - | -- | Logging the fact that utxos provided as collaterals will not be used - -- because the transaction does not involve scripts. There are 2 cases, - -- depending on whether the user has provided an explicit user or a set of - -- utxos to be used as collaterals. - MCLogUnusedCollaterals (Either Peer CollateralIns) - | -- | Logging the automatic addition of a reference script - MCLogAddedReferenceScript TxSkelRedeemer Api.TxOutRef Script.ScriptHash - | -- | Logging the automatic addition of a withdrawal amount - MCLogAutoFilledWithdrawalAmount Api.Credential Api.Lovelace - | -- | Logging the automatic addition of the constitution script - MCLogAutoFilledConstitution Api.ScriptHash - | -- | Logging the automatic adjustment of a min ada amount - MCLogAdjustedTxSkelOut TxSkelOut Api.Lovelace - | -- | Logging the existence of failures uncovered during the computation of - -- execution units, when they're not treated as fatal. - MCELogExUnitsFailures ExUnitsFailures - | -- | Logging the existence of failures uncovered during submission, when - -- they're not treated as fatal. - MCELogSubmissionFailures SubmissionFailures - deriving (Show) - -- | An effect to allow logging of mockchain events data Log :: Effect where - LogEvent :: MockChainLogEntry -> Log m () + LogEvent :: ChainLogEntry -> Log m () makeSem_ ''Log +-- | Logs an internal event occurring while processing a transaction skeleton +logEvent :: (Member Log effs) => ChainLogEntry -> Sem effs () + -- | Interpreting a `Log` in terms of a writer of -- @[MockChainLogEntry]@ runMockChainLog :: - (Member (Writer j) effs) => - (MockChainLogEntry -> j) -> + (Member (Writer ChainJournal) effs) => Sem (Log : effs) a -> Sem effs a -runMockChainLog inject = interpret $ \(LogEvent event) -> tell $ inject event - --- | Logs an internal event occurring while processing a transaction skeleton -logEvent :: (Member Log effs) => MockChainLogEntry -> Sem effs () +runMockChainLog = interpret $ \(LogEvent event) -> tell $ fromLogEntry event + +-- | Interpreting a 'Log' by directly producing a trace on the standard output +-- for each log entry. +runBlockChainLog :: + ( Members + '[ (Embed IO), + State PrettyCookedOpts, + State ChainIndex + ] + effs + ) => + Sem (Log : effs) a -> + Sem effs a +runBlockChainLog = interpret $ \(LogEvent event) -> do + opts <- get + index <- gets chainIndexOutputs + embed $ printCookedOpt opts $ Contextualized index event diff --git a/src/Cooked/Effect/Override.hs b/src/Cooked/Effect/Override.hs index 567607825..afb907586 100644 --- a/src/Cooked/Effect/Override.hs +++ b/src/Cooked/Effect/Override.hs @@ -50,6 +50,21 @@ data Override :: Effect where makeSem_ ''Override +-- | Updates the current parameters +setParams :: (Member Override effs) => Emulator.Params -> Sem effs () + +-- | Sets the current script to act as the official constitution script +setConstitutionScript :: (Member Override effs, ToVScript s) => s -> Sem effs () + +-- | Forces the generation of utxos corresponding to certain +-- `TxSkelOut`. Returns the created UTxOs, which might differ from the original +-- list if some min ADA adjustment occurred. +forceOutputs :: (Member Override effs) => [TxSkelOut] -> Sem effs Utxos + +-- | Same as `forceOutputs`, but discards the returned outputs +forceOutputs_ :: (Member Override effs) => [TxSkelOut] -> Sem effs () +forceOutputs_ = void . forceOutputs + -- | Interprets the `Override` effect runMockChainOverride :: forall effs a. @@ -100,18 +115,3 @@ runMockChainOverride = interpret $ \case modify' $ addOutputs outputsList -- Finally, we return the created utxos return $ Map.fromList outputsList - --- | Updates the current parameters -setParams :: (Member Override effs) => Emulator.Params -> Sem effs () - --- | Sets the current script to act as the official constitution script -setConstitutionScript :: (Member Override effs, ToVScript s) => s -> Sem effs () - --- | Forces the generation of utxos corresponding to certain --- `TxSkelOut`. Returns the created UTxOs, which might differ from the original --- list if some min ADA adjustment occurred. -forceOutputs :: (Member Override effs) => [TxSkelOut] -> Sem effs Utxos - --- | Same as `forceOutputs`, but discards the returned outputs -forceOutputs_ :: (Member Override effs) => [TxSkelOut] -> Sem effs () -forceOutputs_ = void . forceOutputs diff --git a/src/Cooked/Effect/Query.hs b/src/Cooked/Effect/Query.hs index b0b96a254..c1ebf2b78 100644 --- a/src/Cooked/Effect/Query.hs +++ b/src/Cooked/Effect/Query.hs @@ -254,7 +254,7 @@ runMockChainQuery = interpret $ \case res <- gets $ Map.lookup oRef . chainIndexOutputs case res of Just (txSkelOut, True) -> return txSkelOut - _ -> throw $ MCEUnknownOutRef oRef + _ -> throw $ CEUnknownOutRef oRef AllUtxos -> fetchUtxos $ const True UtxosAt (Script.toAddress -> addr) -> fetchUtxos $ (== addr) . Script.toAddress GetConstitutionScript -> gets $ view chainIndexConstitutionL @@ -307,7 +307,7 @@ runBlockChainQuery = interpret $ \case TxSkelOutByRef oRef -> do txIn <- fromEither $ P.Ledger.toCardanoTxIn oRef utxo <- queryUtxosAndHandleErrors $ Cardano.QueryUTxOByTxIn $ Set.singleton txIn - maybe (throw $ MCEUnknownOutRef oRef) return $ Map.lookup oRef utxo + maybe (throw $ CEUnknownOutRef oRef) return $ Map.lookup oRef utxo GetConstitutionScript -> do -- We retrieve the official optional script hash of the current constitution Cardano.Constitution _ mScriptHash <- diff --git a/src/Cooked/Effect/Validation.hs b/src/Cooked/Effect/Validation.hs index adadfe964..5a9362ae2 100644 --- a/src/Cooked/Effect/Validation.hs +++ b/src/Cooked/Effect/Validation.hs @@ -26,6 +26,7 @@ import Cooked.Effect.Params import Cooked.Effect.Query import Cooked.Effect.Submission import Cooked.Runtime.Error +import Cooked.Runtime.Journal import Cooked.Runtime.State import Cooked.Skeleton import Cooked.Utilities.Aliases @@ -103,18 +104,18 @@ runMockChainValidate = interpret $ \case -- We fetch the skeleton options let TxSkelOpts {..} = txSkelOpts txSkel -- We log the submission of the new skeleton - logEvent $ MCLogSubmittedTxSkel txSkel + logEvent $ CLogSubmittedTxSkel txSkel -- We run the automation pipeline on the original skeleton eSkel@(ExtendedTxSkel finalTxSkel fee mCollaterals txBody exUnitsFailures) <- runAutomationPipeline txSkel -- We log the adjusted skeleton - logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals + logEvent $ CLogAdjustedTxSkel finalTxSkel fee mCollaterals -- We handle the execution units failures when applicable when (notNull exUnitsFailures) $ if txSkelOptHaltOnExUnitsFailures -- If requested, we treat them as fatal, ending the run - then throw $ MCEExUnitsFailures exUnitsFailures + then throw $ CEExUnitsFailures exUnitsFailures -- Otherwise, we just log them - else logEvent $ MCELogExUnitsFailures exUnitsFailures + else logEvent $ CELogExUnitsFailures exUnitsFailures -- We build the Cardano transaction, and apply on it the modification in the -- skeleton option let cardanoTx = txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx (view txSkelSignatoriesL finalTxSkel) txBody @@ -128,9 +129,9 @@ runMockChainValidate = interpret $ \case when (notNull submissionFailures) $ if txSkelOptHaltOnSubmissionFailures -- If requested, we treat them as fatal, ending the run - then throw $ MCESubmissionFailures submissionFailures + then throw $ CESubmissionFailures submissionFailures -- Otherwise, we just log them - else logEvent $ MCELogSubmissionFailures submissionFailures + else logEvent $ CELogSubmissionFailures submissionFailures -- We compute the set of consumed outputs and new outputs, based on the -- validity of the transaction, producing some validity logs in the process. (consumedInputs, newOutputs) <- @@ -140,11 +141,11 @@ runMockChainValidate = interpret $ \case | null submissionFailures && null exUnitsFailures -> do let inputs = Map.keysSet $ txSkelInputs finalTxSkel outputs = fromCardanoIndex (P.Ledger.getCardanoTxProducedOutputs pCardanoTx) $ txSkelOutputs finalTxSkel - logEvent $ MCLogNewTx txId $ Valid (length inputs) (Map.size outputs) + logEvent $ CLogNewTx txId $ Valid (length inputs) (Map.size outputs) return (inputs, outputs) -- the transaction fails in phase 1, the index remains unchanged. | notNull submissionFailures -> do - logEvent $ MCLogNewTx txId InvalidPhase1 + logEvent $ CLogNewTx txId InvalidPhase1 return (Set.empty, Map.empty) -- the transaction fails in phase 2, but no collaterals were -- provided. This is an unreachable case. @@ -156,7 +157,7 @@ runMockChainValidate = interpret $ \case -- transaction. | Just (colIns, retCol) <- mCollaterals -> do let outputs = fromCardanoIndex (P.Ledger.getCardanoTxProducedReturnCollateral pCardanoTx) $ toList retCol - logEvent $ MCLogNewTx txId $ InvalidPhase2 (length colIns) (Map.size outputs) + logEvent $ CLogNewTx txId $ InvalidPhase2 (length colIns) (Map.size outputs) return (colIns, outputs) -- We update the index with the consumed and produced outputs modify' $ removeOutputs consumedInputs diff --git a/src/Cooked/MockChain.hs b/src/Cooked/MockChain.hs index 54bd1c790..f86dcb11f 100644 --- a/src/Cooked/MockChain.hs +++ b/src/Cooked/MockChain.hs @@ -3,8 +3,9 @@ -- tweaking and testing). module Cooked.MockChain (module X) where +import Cooked.MockChain.Config as X import Cooked.MockChain.Instances as X import Cooked.MockChain.Ltl as X -import Cooked.MockChain.Runnable as X +import Cooked.MockChain.Run as X import Cooked.MockChain.Testing as X import Cooked.MockChain.Tweak as X diff --git a/src/Cooked/MockChain/Runnable.hs b/src/Cooked/MockChain/Config.hs similarity index 66% rename from src/Cooked/MockChain/Runnable.hs rename to src/Cooked/MockChain/Config.hs index 978ff6b8b..8640c8b6a 100644 --- a/src/Cooked/MockChain/Runnable.hs +++ b/src/Cooked/MockChain/Config.hs @@ -1,6 +1,7 @@ --- | This module exposes the infrastructure to execute mockchain and blockchain --- runs, in particular initial configurations, results, and running functions. -module Cooked.MockChain.Runnable +-- | This module exposes the configuration elements required to execute a +-- mockchain run. This includes the initial parameters (with an initial +-- distribution of funds), and various ways of processing the results of a run. +module Cooked.MockChain.Config ( -- * Initial distributions InitialDistribution, initialDistributionTemplate, @@ -15,17 +16,9 @@ module Cooked.MockChain.Runnable MockChainReturn (..), FunOnMockChainResult, unRawMockChainReturn, - - -- * Running mockchains - RunnableMockChain (..), - runMockChainFromConf, - runMockChainFromInitDist, - runMockChainFromInitDistTemplate, - runMockChainDef, ) where -import Cooked.Effect.Override import Cooked.Runtime.Error import Cooked.Runtime.Journal import Cooked.Runtime.State @@ -36,7 +29,6 @@ import Data.List (foldl') import Data.Map (Map) import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api -import Polysemy -- | Describes the initial distribution of UTxOs per user. -- @@ -114,51 +106,3 @@ data MockChainConf a b where -- initial distribution, and returns a refined `MockChainReturn` mockChainConfTemplate :: MockChainConf a (MockChainReturn a) 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 `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 :: - ( RunnableMockChain effs, - Member Override effs - ) => - MockChainConf a b -> - Sem effs a -> - [b] -runMockChainFromConf (MockChainConf emInitState ciInitState initDist funOnResult) currentRun = - fmap funOnResult $ - runMockChain emInitState ciInitState $ - forceOutputs initDist >> currentRun - --- | Runs a `RunnableMockChain` from an initial distribution -runMockChainFromInitDist :: - ( RunnableMockChain effs, - Member Override effs - ) => - InitialDistribution -> - Sem effs a -> - [MockChainReturn a] -runMockChainFromInitDist initDist = - runMockChainFromConf $ mockChainConfTemplate {mccInitialDistribution = initDist} - --- | Same as `runMockChainFromInitDist` using the `initialDistributionTemplate` -runMockChainFromInitDistTemplate :: - ( RunnableMockChain effs, - Member Override effs - ) => - Sem effs a -> - [MockChainReturn a] -runMockChainFromInitDistTemplate = runMockChainFromInitDist initialDistributionTemplate - --- | Runs a `RunnableMockChain` from a default configuration -runMockChainDef :: - ( RunnableMockChain effs, - Member Override effs - ) => - Sem effs a -> - [MockChainReturn a] -runMockChainDef = runMockChainFromConf mockChainConfTemplate diff --git a/src/Cooked/MockChain/Instances.hs b/src/Cooked/MockChain/Instances.hs index 5bf0645c0..ddcd694c5 100644 --- a/src/Cooked/MockChain/Instances.hs +++ b/src/Cooked/MockChain/Instances.hs @@ -56,7 +56,7 @@ import Cooked.Effect.Submission import Cooked.Effect.Time import Cooked.Effect.Validation import Cooked.MockChain.Ltl -import Cooked.MockChain.Runnable +import Cooked.MockChain.Run import Cooked.MockChain.Tweak import Cooked.Runtime.Error import Cooked.Runtime.Journal @@ -88,11 +88,11 @@ instance RunnableMockChain DirectEffs where (: []) . run . runWriter - . runMockChainLog fromLogEntry + . runMockChainLog . runState ciInit . runState emInit . runError - . mapError MCEToCardanoError + . mapError CEToCardanoError . runFailInChainError . runMockChainMisc . runMockChainParams @@ -165,11 +165,11 @@ instance RunnableMockChain FullEffs where run . runNonDet . runWriter - . runMockChainLog fromLogEntry + . runMockChainLog . runState ciInit . runState emInit . runError - . mapError MCEToCardanoError + . mapError CEToCardanoError . runFailInChainError . runMockChainParams . runMockChainTime @@ -228,11 +228,11 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr run . runNonDet . runWriter - . runMockChainLog fromLogEntry + . runMockChainLog . runState ciInit . runState emInit . runError - . mapError MCEToCardanoError + . mapError CEToCardanoError . runFailInChainError . runMockChainParams . runMockChainTime diff --git a/src/Cooked/MockChain/Run.hs b/src/Cooked/MockChain/Run.hs new file mode 100644 index 000000000..f7f7016b1 --- /dev/null +++ b/src/Cooked/MockChain/Run.hs @@ -0,0 +1,63 @@ +-- | This module exposes the infrastructure to execute mockchain runs +module Cooked.MockChain.Run + ( -- * Running mockchains + RunnableMockChain (..), + runMockChainFromConf, + runMockChainFromInitDist, + runMockChainFromInitDistTemplate, + runMockChainDef, + ) +where + +import Cooked.Effect.Override +import Cooked.MockChain.Config +import Cooked.Runtime.State +import Polysemy + +-- | The class of effects that represent a mockchain run +class RunnableMockChain effs where + -- | 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 :: + ( RunnableMockChain effs, + Member Override effs + ) => + MockChainConf a b -> + Sem effs a -> + [b] +runMockChainFromConf (MockChainConf emInitState ciInitState initDist funOnResult) currentRun = + fmap funOnResult $ + runMockChain emInitState ciInitState $ + forceOutputs initDist >> currentRun + +-- | Runs a `RunnableMockChain` from an initial distribution +runMockChainFromInitDist :: + ( RunnableMockChain effs, + Member Override effs + ) => + InitialDistribution -> + Sem effs a -> + [MockChainReturn a] +runMockChainFromInitDist initDist = + runMockChainFromConf $ mockChainConfTemplate {mccInitialDistribution = initDist} + +-- | Same as `runMockChainFromInitDist` using the `initialDistributionTemplate` +runMockChainFromInitDistTemplate :: + ( RunnableMockChain effs, + Member Override effs + ) => + Sem effs a -> + [MockChainReturn a] +runMockChainFromInitDistTemplate = runMockChainFromInitDist initialDistributionTemplate + +-- | Runs a `RunnableMockChain` from a default configuration +runMockChainDef :: + ( RunnableMockChain effs, + Member Override effs + ) => + Sem effs a -> + [MockChainReturn a] +runMockChainDef = runMockChainFromConf mockChainConfTemplate diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index 43a32c0fc..4f1dc950b 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -88,9 +88,9 @@ where import Cardano.Ledger.Alonzo.Plutus.Evaluate qualified as Alonzo import Control.Exception qualified as E import Control.Monad -import Cooked.Effect.Log import Cooked.Effect.Override -import Cooked.MockChain.Runnable +import Cooked.MockChain.Config +import Cooked.MockChain.Run import Cooked.Pretty import Cooked.Runtime.Error import Cooked.Runtime.Journal @@ -274,10 +274,10 @@ assertSameSets l r = --} -- | Type of properties over failures -type FailureProp prop = PrettyCookedOpts -> [MockChainLogEntry] -> ChainError -> UtxoState -> prop +type FailureProp prop = PrettyCookedOpts -> [ChainLogEntry] -> ChainError -> UtxoState -> prop -- | Type of properties over successes -type SuccessProp a prop = PrettyCookedOpts -> [MockChainLogEntry] -> a -> UtxoState -> prop +type SuccessProp a prop = PrettyCookedOpts -> [ChainLogEntry] -> a -> UtxoState -> prop -- | Type of properties over the number of run outcomes. This does not -- necessitate a 'PrettyCookedOpts' as parameter as an 'Integer' does not @@ -285,7 +285,7 @@ type SuccessProp a prop = PrettyCookedOpts -> [MockChainLogEntry] -> a -> UtxoSt type SizeProp prop = Integer -> prop -- | Type of properties over the mockchain log -type LogProp prop = PrettyCookedOpts -> [MockChainLogEntry] -> prop +type LogProp prop = PrettyCookedOpts -> [ChainLogEntry] -> prop -- | Type of properties over the 'UtxoState' type StateProp prop = PrettyCookedOpts -> UtxoState -> prop @@ -570,8 +570,8 @@ isValidationFailure _ = False isPhase1Failure :: (IsProp prop) => FailureProp prop -isPhase1Failure _ _ (MCESubmissionFailures _) _ = testSuccess -isPhase1Failure _ _ (MCEExUnitsFailures failures) _ +isPhase1Failure _ _ (CESubmissionFailures _) _ = testSuccess +isPhase1Failure _ _ (CEExUnitsFailures failures) _ | not (any isValidationFailure (Map.elems failures)) = testSuccess isPhase1Failure pcOpts _ e _ = testFailureMsg $ @@ -582,7 +582,7 @@ isPhase1Failure pcOpts _ e _ = isPhase2Failure :: (IsProp prop) => FailureProp prop -isPhase2Failure _ _ (MCEExUnitsFailures failures) _ +isPhase2Failure _ _ (CEExUnitsFailures failures) _ | any isValidationFailure (Map.elems failures) = testSuccess isPhase2Failure pcOpts _ e _ = testFailureMsg $ @@ -594,9 +594,9 @@ isPhase1FailureWithMsg :: (IsProp prop) => String -> FailureProp prop -isPhase1FailureWithMsg s _ _ (MCESubmissionFailures failures) _ +isPhase1FailureWithMsg s _ _ (CESubmissionFailures failures) _ | any (isInfixOf s . show) failures = testSuccess -isPhase1FailureWithMsg s _ _ (MCEExUnitsFailures failures) _ +isPhase1FailureWithMsg s _ _ (CEExUnitsFailures failures) _ | any (\f -> not (isValidationFailure f) && s `isInfixOf` show f) (Map.elems failures) = testSuccess isPhase1FailureWithMsg _ pcOpts _ e _ = testFailureMsg $ @@ -608,7 +608,7 @@ isPhase2FailureWithMsg :: (IsProp prop) => String -> FailureProp prop -isPhase2FailureWithMsg s _ _ (MCEExUnitsFailures failures) _ +isPhase2FailureWithMsg s _ _ (CEExUnitsFailures failures) _ | not $ null [text | Alonzo.ValidationFailure _ _ logs _ <- Map.elems failures, (T.unpack -> text) <- logs, s `isInfixOf` text] = testSuccess isPhase2FailureWithMsg _ pcOpts _ e _ = testFailureMsg $ diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index 08240e00c..b333bf806 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -4,8 +4,7 @@ -- 'PrettyCookedMaybe' instances for data types returned by a @MockChain@ run. module Cooked.Pretty.MockChain () where -import Cooked.Effect.Log -import Cooked.MockChain.Runnable +import Cooked.MockChain.Config import Cooked.Pretty.Class import Cooked.Pretty.Options import Cooked.Pretty.Skeleton @@ -86,55 +85,55 @@ instance PrettyCooked BalancingError where ] instance PrettyCooked ChainError where - prettyCookedOpt opts (MCEExUnitsFailures failures) = + prettyCookedOpt opts (CEExUnitsFailures failures) = prettyItemize opts "Execution units failures:" "-" (PP.viaShow <$> Map.elems failures :: [DocCooked]) - prettyCookedOpt opts (MCESubmissionFailures failures) = + prettyCookedOpt opts (CESubmissionFailures failures) = prettyItemize opts "Submission failures:" "-" (PP.viaShow <$> failures :: [DocCooked]) - prettyCookedOpt opts (MCEBalancingError err) = prettyCookedOpt opts err - prettyCookedOpt _ (MCEToCardanoError cardanoError) = + prettyCookedOpt opts (CEBalancingError err) = prettyCookedOpt opts err + prettyCookedOpt _ (CEToCardanoError cardanoError) = "Transaction generation error:" <+> PP.pretty cardanoError - prettyCookedOpt opts (MCEUnknownOutRef txOutRef) = "Unknown transaction output ref:" <+> prettyCookedOpt opts txOutRef - prettyCookedOpt opts (MCEWrongReferenceScriptError oRef expected got) = + prettyCookedOpt opts (CEUnknownOutRef txOutRef) = "Unknown transaction output ref:" <+> prettyCookedOpt opts txOutRef + prettyCookedOpt opts (CEWrongReferenceScriptError oRef expected got) = "Unable to fetch the following reference script:" <+> prettyHash opts expected <+> "in the following UTxO:" <+> prettyCookedOpt opts oRef <+> "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) = + prettyCookedOpt _ (CEUnsupportedFeature feature) = "Unsupported feature:" <+> PP.pretty feature + prettyCookedOpt opts (CESpendingHashOnlyDatum 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 opts (MCESpendingHashOnlyScript txOutRef scriptHash) = + prettyCookedOpt opts (CESpendingHashOnlyScript 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 _ (MCEFailure msg) = "Failed with:" <+> PP.pretty msg + prettyCookedOpt _ (CEFailure msg) = "Failed with:" <+> PP.pretty msg -instance PrettyCooked (Contextualized [MockChainLogEntry]) where +instance PrettyCooked (Contextualized [ChainLogEntry]) where prettyCookedOpt opts (Contextualized outputs entries) = prettyItemize opts "📖 MockChain run log:" "⁍" (fmap (prettyCookedOpt opts . Contextualized outputs) entries) --- | This prints a 'MockChainLogEntry'. In the log, we know a transaction has --- been validated if the 'MCLogSubmittedTxSkel' is followed by a 'MCLogNewTx'. -instance PrettyCooked (Contextualized MockChainLogEntry) where - prettyCookedOpt opts (Contextualized _ (MCLogAdjustedTxSkelOut skelOut newAda)) = +-- | This prints a 'ChainLogEntry'. In the log, we know a transaction has +-- been validated if the 'CLogSubmittedTxSkel' is followed by a 'CLogNewTx'. +instance PrettyCooked (Contextualized ChainLogEntry) where + prettyCookedOpt opts (Contextualized _ (CLogAdjustedTxSkelOut skelOut newAda)) = prettyItemize opts ("New ADA adjustment of" <+> prettyCookedOpt opts (Script.toValue newAda) <+> "performed for output:") "-" skelOut - prettyCookedOpt opts (Contextualized outputs (MCLogSubmittedTxSkel skel)) = + prettyCookedOpt opts (Contextualized outputs (CLogSubmittedTxSkel skel)) = prettyItemize opts "New raw skeleton submitted to the adjustment pipeline:" "-" (Contextualized outputs skel) - prettyCookedOpt opts (Contextualized outputs (MCLogAdjustedTxSkel skel fee mCollaterals)) = + prettyCookedOpt opts (Contextualized outputs (CLogAdjustedTxSkel skel fee mCollaterals)) = prettyItemize opts "New adjusted skeleton submitted for validation:" @@ -153,7 +152,7 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where mCollaterals ) ) - prettyCookedOpt opts (Contextualized _ (MCLogNewTx txId validity)) = + prettyCookedOpt opts (Contextualized _ (CLogNewTx txId validity)) = prettyItemize opts "New transaction produced:" @@ -173,11 +172,11 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where "Number of return collateral outputs:" <+> PP.pretty nbRetColOutputs ] ) - prettyCookedOpt opts (Contextualized _ (MCELogExUnitsFailures failures)) = + prettyCookedOpt opts (Contextualized _ (CELogExUnitsFailures failures)) = prettyItemize opts "Warning: execution units failures:" "-" (PP.viaShow <$> Map.elems failures :: [DocCooked]) - prettyCookedOpt opts (Contextualized _ (MCELogSubmissionFailures failures)) = + prettyCookedOpt opts (Contextualized _ (CELogSubmissionFailures failures)) = prettyItemize opts "Warning: submission failures:" "-" (PP.viaShow <$> failures :: [DocCooked]) - prettyCookedOpt opts (Contextualized _ (MCLogDiscardedUtxos n s)) = + prettyCookedOpt opts (Contextualized _ (CLogDiscardedUtxos n s)) = prettyItemize @[DocCooked] opts "Warning:" @@ -185,7 +184,7 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where [ PP.pretty n <+> "balancing UTxOs were discarded", PP.pretty s ] - prettyCookedOpt opts (Contextualized _ (MCLogUnusedCollaterals source)) = + prettyCookedOpt opts (Contextualized _ (CLogUnusedCollaterals source)) = prettyItemize opts "Warning" @@ -194,7 +193,7 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where "Source:" <+> either (prettyCookedOpt opts) (("Given set of size" <+>) . PP.pretty . length) source, "The transaction does not require any collateral" ] - prettyCookedOpt opts (Contextualized _ (MCLogAddedReferenceScript red oRef sHash)) = + prettyCookedOpt opts (Contextualized _ (CLogAddedReferenceScript red oRef sHash)) = prettyItemize opts "New automated attachment of a reference script:" @@ -204,13 +203,13 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where ] ++ prettyCookedOptList opts red ) - prettyCookedOpt opts (Contextualized _ (MCLogAutoFilledWithdrawalAmount cred amount)) = + prettyCookedOpt opts (Contextualized _ (CLogAutoFilledWithdrawalAmount cred amount)) = prettyItemize opts "New auto-filled withdrawal amount:" "-" [prettyCookedOpt opts cred, prettyCookedOpt opts (Script.toValue amount)] - prettyCookedOpt opts (Contextualized _ (MCLogAutoFilledConstitution constitution)) = + prettyCookedOpt opts (Contextualized _ (CLogAutoFilledConstitution constitution)) = "New auto-filled constitution:" <+> prettyHash opts constitution -- | Pretty print a 'UtxoState'. Print the known wallets first, then unknown diff --git a/src/Cooked/Runtime/Error.hs b/src/Cooked/Runtime/Error.hs index 54b1125fc..68b6fb7e9 100644 --- a/src/Cooked/Runtime/Error.hs +++ b/src/Cooked/Runtime/Error.hs @@ -39,27 +39,27 @@ data BalancingError -- | Errors that can be produced by the blockchain data ChainError = -- | Failures occurring while computing execution units - MCEExUnitsFailures ExUnitsFailures + CEExUnitsFailures ExUnitsFailures | -- | Failures occurring while submitting the transaction for validation - MCESubmissionFailures SubmissionFailures + CESubmissionFailures SubmissionFailures | -- | Balancing errors - MCEBalancingError BalancingError + CEBalancingError BalancingError | -- | Translating a skeleton element to its Cardano counterpart failed - MCEToCardanoError P.Ledger.ToCardanoError + CEToCardanoError P.Ledger.ToCardanoError | -- | The required reference script is missing from a witness utxo - MCEWrongReferenceScriptError Api.TxOutRef Api.ScriptHash (Maybe Api.ScriptHash) + CEWrongReferenceScriptError Api.TxOutRef Api.ScriptHash (Maybe Api.ScriptHash) | -- | A UTxO is missing from the mockchain state - MCEUnknownOutRef Api.TxOutRef + CEUnknownOutRef Api.TxOutRef | -- | An attempt to invoke an unsupported feature has been made - MCEUnsupportedFeature String + CEUnsupportedFeature 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 + CESpendingHashOnlyDatum 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 + CESpendingHashOnlyScript Api.TxOutRef Api.ScriptHash | -- | Used to provide 'MonadFail' instances. - MCEFailure String + CEFailure String deriving (Show, Eq) -- | Interpreting failures in terms of `ChainError` @@ -69,4 +69,4 @@ runFailInChainError :: Sem (Fail : effs) a -> Sem effs a runFailInChainError = interpret $ - \(Fail s) -> throw $ MCEFailure s + \(Fail s) -> throw $ CEFailure s diff --git a/src/Cooked/Runtime/Journal.hs b/src/Cooked/Runtime/Journal.hs index 8e9161ad6..66e80f211 100644 --- a/src/Cooked/Runtime/Journal.hs +++ b/src/Cooked/Runtime/Journal.hs @@ -1,6 +1,8 @@ -- | This module exposes the various events emitted during a mockchain run. module Cooked.Runtime.Journal - ( ChainJournal (..), + ( TxValidity (..), + ChainLogEntry (..), + ChainJournal (..), fromLogEntry, fromAlias, fromNote, @@ -8,19 +10,66 @@ module Cooked.Runtime.Journal ) where -import Cooked.Effect.Log import Cooked.Pretty.Class import Cooked.Pretty.Options +import Cooked.Skeleton +import Cooked.Utilities.Aliases import Data.Map import Data.Map qualified as Map +import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api +-- | The validity of a transaction +data TxValidity + = -- | The transaction is valid, we store the number of inputs and outputs + Valid Int Int + | -- | The transaction is invalid in phase 1 (no ledger change) + InvalidPhase1 + | -- | The transaction is invalid in phase 2, we store the number of collateral + -- inputs and return collateral outputs + InvalidPhase2 Int Int + deriving (Show) + +-- | Events logged when processing transaction skeletons +data ChainLogEntry + = -- | Logging a Skeleton as it is submitted by the user. + CLogSubmittedTxSkel TxSkel + | -- | Logging a Skeleton as it has been adjusted by the balancing mechanism, + -- alongside fee, and possible collateral utxos and return collateral user. + CLogAdjustedTxSkel TxSkel Fee (Maybe Collaterals) + | -- | Logging the production of a new transaction, with its ID as well as its + -- validity. + CLogNewTx Api.TxId TxValidity + | -- | Logging the fact that utxos provided by the user for balancing have to be + -- discarded for a specific reason. + CLogDiscardedUtxos Integer String + | -- | Logging the fact that utxos provided as collaterals will not be used + -- because the transaction does not involve scripts. There are 2 cases, + -- depending on whether the user has provided an explicit user or a set of + -- utxos to be used as collaterals. + CLogUnusedCollaterals (Either Peer CollateralIns) + | -- | Logging the automatic addition of a reference script + CLogAddedReferenceScript TxSkelRedeemer Api.TxOutRef Script.ScriptHash + | -- | Logging the automatic addition of a withdrawal amount + CLogAutoFilledWithdrawalAmount Api.Credential Api.Lovelace + | -- | Logging the automatic addition of the constitution script + CLogAutoFilledConstitution Api.ScriptHash + | -- | Logging the automatic adjustment of a min ada amount + CLogAdjustedTxSkelOut TxSkelOut Api.Lovelace + | -- | Logging the existence of failures uncovered during the computation of + -- execution units, when they're not treated as fatal. + CELogExUnitsFailures ExUnitsFailures + | -- | Logging the existence of failures uncovered during submission, when + -- they're not treated as fatal. + CELogSubmissionFailures SubmissionFailures + deriving (Show) + -- | This represents the writable elements that can be emitted throughout a -- mockchain run. data ChainJournal where ChainJournal :: { -- | Log entries generated by cooked-validators - mcbLog :: [MockChainLogEntry], + mcbLog :: [ChainLogEntry], -- | Aliases stored by the user mcbAliases :: Map Api.BuiltinByteString String, -- | Notes taken by the user, parameterized by some pretty cooked options, @@ -40,7 +89,7 @@ instance Monoid ChainJournal where mempty = ChainJournal mempty mempty mempty mempty -- | Build a `ChainJournal` from a single log entry -fromLogEntry :: MockChainLogEntry -> ChainJournal +fromLogEntry :: ChainLogEntry -> ChainJournal fromLogEntry entry = mempty {mcbLog = [entry]} -- | Build a `ChainJournal` from a single alias diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index a2a11aff2..960a0ab61 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -209,36 +209,36 @@ testBalancingSucceedsWith msg props run = `withResultProp` \res -> testConjoin (($ res) <$> props) failsAtBalancingWith :: Api.Value -> Wallet -> ChainError -> Assertion -failsAtBalancingWith val' wal' (MCEBalancingError (NotEnoughFund wal val)) = testBool $ val' == val && Script.toPubKeyHash wal' == Script.toPubKeyHash wal +failsAtBalancingWith val' wal' (CEBalancingError (NotEnoughFund wal val)) = testBool $ val' == val && Script.toPubKeyHash wal' == Script.toPubKeyHash wal failsAtBalancingWith _ _ _ = testBool False failsAtBalancing :: ChainError -> Assertion -failsAtBalancing (MCEBalancingError (NotEnoughFund {})) = testBool True -failsAtBalancing (MCEBalancingError (NotEnoughFundForExtraMinAda {})) = testBool True +failsAtBalancing (CEBalancingError (NotEnoughFund {})) = testBool True +failsAtBalancing (CEBalancingError (NotEnoughFundForExtraMinAda {})) = testBool True failsAtBalancing _ = testBool False failsWithTooLittleFee :: ChainError -> Assertion -failsWithTooLittleFee (MCESubmissionFailures failures) = testBool $ any (isInfixOf "FeeTooSmallUTxO" . show) failures +failsWithTooLittleFee (CESubmissionFailures failures) = testBool $ any (isInfixOf "FeeTooSmallUTxO" . show) failures failsWithTooLittleFee _ = testBool False failsWithValueNotConserved :: ChainError -> Assertion -failsWithValueNotConserved (MCESubmissionFailures failures) = testBool $ any (isInfixOf "ValueNotConserved" . show) failures +failsWithValueNotConserved (CESubmissionFailures failures) = testBool $ any (isInfixOf "ValueNotConserved" . show) failures failsWithValueNotConserved _ = testBool False failsWithEmptyTxIns :: ChainError -> Assertion -failsWithEmptyTxIns (MCESubmissionFailures failures) = testBool $ any (isInfixOf "InputSetEmptyUTxO" . show) failures +failsWithEmptyTxIns (CESubmissionFailures failures) = testBool $ any (isInfixOf "InputSetEmptyUTxO" . show) failures failsWithEmptyTxIns _ = testBool False failsAtCollateralsWith :: Integer -> ChainError -> Assertion -failsAtCollateralsWith fee' (MCEBalancingError (NoSuitableCollateral fee percentage val)) = testBool $ fee == fee' && val == Script.lovelace (1 + (fee * percentage) `div` 100) +failsAtCollateralsWith fee' (CEBalancingError (NoSuitableCollateral fee percentage val)) = testBool $ fee == fee' && val == Script.lovelace (1 + (fee * percentage) `div` 100) failsAtCollateralsWith _ _ = testBool False failsAtCollaterals :: ChainError -> Assertion -failsAtCollaterals (MCEBalancingError (NoSuitableCollateral {})) = testBool True +failsAtCollaterals (CEBalancingError (NoSuitableCollateral {})) = testBool True failsAtCollaterals _ = testBool False failsLackOfCollateralWallet :: ChainError -> Assertion -failsLackOfCollateralWallet (MCEBalancingError MissingBalancingUser) = testBool True +failsLackOfCollateralWallet (CEBalancingError MissingBalancingUser) = testBool True failsLackOfCollateralWallet _ = testBool False testBalancingFailsWith :: (Show a) => String -> (ChainError -> Assertion) -> FullMockChain a -> TestTree diff --git a/tests/Spec/ProposingScript.hs b/tests/Spec/ProposingScript.hs index c232fa595..5213612c1 100644 --- a/tests/Spec/ProposingScript.hs +++ b/tests/Spec/ProposingScript.hs @@ -69,37 +69,37 @@ tests = mustFailTest (testProposingScript False False checkProposingScript (Just alwaysTrueProposingValidator) (ParameterChange [FeePerByte 100])) `withFailureProp` isPhase1FailureWithMsg "InvalidPolicyHash" - `withLogProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "CLogAutoFilledConstitution", testCooked "Success when executing the right constitution script" $ mustSucceedTest (testProposingScript False False alwaysTrueProposingValidator (Just alwaysTrueProposingValidator) (ParameterChange [FeePerByte 100])) - `withLogProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "CLogAutoFilledConstitution", testCooked "Success when executing a more complex constitution script" $ mustSucceedTest (testProposingScript False False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 100])) - `withLogProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "CLogAutoFilledConstitution", testCooked "Failure when executing a more complex constitution script with the wrong proposal" $ mustFailInPhase2Test (testProposingScript False False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 50])) - `withLogProp` didNotHappen "MCLogAutoFilledConstitution", + `withLogProp` didNotHappen "CLogAutoFilledConstitution", testCooked "Success when executing a more complex constitution script as a reference script" $ mustSucceedTest (testProposingScript True False checkProposingScript (Just checkProposingScript) (ParameterChange [FeePerByte 100])) - `withLogProp` happened "MCLogAddedReferenceScript" - `withLogProp` didNotHappen "MCLogAutoFilledConstitution" + `withLogProp` happened "CLogAddedReferenceScript" + `withLogProp` didNotHappen "CLogAutoFilledConstitution" ], testGroup "Automated constitution attachment" [ testCooked "Success when auto assigning the constitution script" $ mustSucceedTest (testProposingScript False True checkProposingScript Nothing (ParameterChange [FeePerByte 100])) - `withLogProp` happened "MCLogAutoFilledConstitution", + `withLogProp` happened "CLogAutoFilledConstitution", testCooked "Success when auto assigning the constitution script and using it as a reference script" $ mustSucceedTest (testProposingScript True True checkProposingScript Nothing (ParameterChange [FeePerByte 100])) - `withLogProp` happened "MCLogAddedReferenceScript" - `withLogProp` happened "MCLogAutoFilledConstitution", + `withLogProp` happened "CLogAddedReferenceScript" + `withLogProp` happened "CLogAutoFilledConstitution", testCooked "Success when auto assigning the constitution script while overriding an existing one" $ mustSucceedTest (testProposingScript False True checkProposingScript (Just alwaysFalseProposingValidator) (ParameterChange [FeePerByte 100])) - `withLogProp` happened "MCLogAutoFilledConstitution" + `withLogProp` happened "CLogAutoFilledConstitution" ] ] diff --git a/tests/Spec/ReferenceScripts.hs b/tests/Spec/ReferenceScripts.hs index 6cad7f154..3c18e45b9 100644 --- a/tests/Spec/ReferenceScripts.hs +++ b/tests/Spec/ReferenceScripts.hs @@ -166,7 +166,7 @@ tests = } ) `withErrorProp` \case - MCEUnknownOutRef _ -> testSuccess + CEUnknownOutRef _ -> testSuccess _ -> testFailure, testCookedFromInitDistTemplate "fail from transaction generation for mismatching reference scripts" $ mustFailTest @@ -185,7 +185,7 @@ tests = } ) `withErrorProp` \case - MCEWrongReferenceScriptError {} -> testSuccess + CEWrongReferenceScriptError {} -> testSuccess _ -> testFailure, testCookedFromInitDistTemplate "phase 1 - fail if using a reference script with 'someRedeemer'" $ mustFailInPhase1Test $ do @@ -242,16 +242,16 @@ tests = referenceMint Script.alwaysSucceedPolicyVersioned Script.alwaysSucceedPolicyVersioned 0 False, testCookedFromInitDistTemplate "succeed if relying on automated finding of reference minting policy" $ mustSucceedTest (referenceMint Script.alwaysSucceedPolicyVersioned Script.alwaysSucceedPolicyVersioned 0 True) - `withLogProp` happened "MCLogAddedReferenceScript", + `withLogProp` happened "CLogAddedReferenceScript", testCookedFromInitDistTemplate "fail if given the wrong reference minting policy" $ mustFailTest (referenceMint Script.alwaysFailPolicyVersioned Script.alwaysSucceedPolicyVersioned 0 False) `withErrorProp` \case - MCEWrongReferenceScriptError {} -> testSuccess + CEWrongReferenceScriptError {} -> testSuccess _ -> testFailure, testCookedFromInitDistTemplate "fail if referencing the wrong utxo" $ mustFailTest (referenceMint Script.alwaysSucceedPolicyVersioned Script.alwaysSucceedPolicyVersioned 1 False) `withErrorProp` \case - MCEWrongReferenceScriptError {} -> testSuccess + CEWrongReferenceScriptError {} -> testSuccess _ -> testFailure ] ] diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index ef1a3e7f4..d39f3c669 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -28,7 +28,7 @@ runSlot :: runSlot = run . runError - . mapError MCEToCardanoError + . mapError CEToCardanoError . runFailInChainError . evalState def . evalState def diff --git a/tests/Spec/Withdrawals.hs b/tests/Spec/Withdrawals.hs index 4c3d0ec8b..91a2114af 100644 --- a/tests/Spec/Withdrawals.hs +++ b/tests/Spec/Withdrawals.hs @@ -64,7 +64,7 @@ tests = (scriptUserWithdrawing 0) Nothing ) - `withLogProp` happened "MCLogAutoFilledWithdrawalAmount", + `withLogProp` happened "CLogAutoFilledWithdrawalAmount", testCooked ".. but the script's logic might say No" $ mustFailTest ( testWithdrawingScript @@ -73,7 +73,7 @@ tests = Nothing ) `withFailureProp` isPhase2FailureWithMsg "Wrong quantity: 0 instead of 2000000" - `withLogProp` happened "MCLogAutoFilledWithdrawalAmount", + `withLogProp` happened "CLogAutoFilledWithdrawalAmount", testCooked "We cannot withdraw more than our rewards (0)" $ mustFailTest ( testWithdrawingScript @@ -82,7 +82,7 @@ tests = (Just 2) ) `withFailureProp` isPhase1FailureWithMsg "WithdrawalsNotInRewardsCERTS" - `withLogProp` didNotHappen "MCLogAutoFilledWithdrawalAmount", + `withLogProp` didNotHappen "CLogAutoFilledWithdrawalAmount", testCooked "A peer can also make a withdrawal" $ mustSucceedTest ( testWithdrawingScript @@ -90,5 +90,5 @@ tests = aliceUser Nothing ) - `withLogProp` happened "MCLogAutoFilledWithdrawalAmount" + `withLogProp` happened "CLogAutoFilledWithdrawalAmount" ] From 932940d695e6f3f87ad2fb7a9ae024612045a3a1 Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 13 Aug 2026 00:26:21 +0200 Subject: [PATCH 35/39] refactoring Cooked.BlockChain --- cooked-validators.cabal | 3 ++- src/Cooked/BlockChain.hs | 7 ++++--- src/Cooked/BlockChain/Config.hs | 4 ++++ src/Cooked/BlockChain/{Runnable.hs => Run.hs} | 5 ++++- 4 files changed, 14 insertions(+), 5 deletions(-) create mode 100644 src/Cooked/BlockChain/Config.hs rename src/Cooked/BlockChain/{Runnable.hs => Run.hs} (80%) diff --git a/cooked-validators.cabal b/cooked-validators.cabal index 4c8ba75d7..759b40be6 100644 --- a/cooked-validators.cabal +++ b/cooked-validators.cabal @@ -40,8 +40,9 @@ library Cooked.Automation.GenerateTx.Withdrawals Cooked.Automation.GenerateTx.Witness Cooked.BlockChain + Cooked.BlockChain.Config Cooked.BlockChain.Instances - Cooked.BlockChain.Runnable + Cooked.BlockChain.Run Cooked.Effect Cooked.Effect.Log Cooked.Effect.Misc diff --git a/src/Cooked/BlockChain.hs b/src/Cooked/BlockChain.hs index b66df75d4..572dcb709 100644 --- a/src/Cooked/BlockChain.hs +++ b/src/Cooked/BlockChain.hs @@ -1,7 +1,8 @@ -- | This module centralizes the node-backend (BlockChain) running code. It is -- an umbrella re-exporting all the BlockChain submodules, which only provide -- instances. -module Cooked.BlockChain () where +module Cooked.BlockChain (module X) where -import Cooked.BlockChain.Instances () -import Cooked.BlockChain.Runnable () +import Cooked.BlockChain.Config as X +import Cooked.BlockChain.Instances as X +import Cooked.BlockChain.Run as X diff --git a/src/Cooked/BlockChain/Config.hs b/src/Cooked/BlockChain/Config.hs new file mode 100644 index 000000000..3eadfdbb1 --- /dev/null +++ b/src/Cooked/BlockChain/Config.hs @@ -0,0 +1,4 @@ +module Cooked.BlockChain.Config + ( + ) +where diff --git a/src/Cooked/BlockChain/Runnable.hs b/src/Cooked/BlockChain/Run.hs similarity index 80% rename from src/Cooked/BlockChain/Runnable.hs rename to src/Cooked/BlockChain/Run.hs index 9d338a51b..2db8c32e9 100644 --- a/src/Cooked/BlockChain/Runnable.hs +++ b/src/Cooked/BlockChain/Run.hs @@ -1,4 +1,7 @@ -- | This module exposes the infrastructure to execute blockchain runs against a -- real node backend, mirroring 'Cooked.MockChain.Runnable' which targets the -- emulated chain. -module Cooked.BlockChain.Runnable () where +module Cooked.BlockChain.Run + ( + ) +where From e3aee07dbe6efd38c6ccacad717da832d91f2c6e Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 13 Aug 2026 03:06:30 +0200 Subject: [PATCH 36/39] blockchain intances and runs --- src/Cooked/BlockChain/Config.hs | 53 +++++++++++++- src/Cooked/BlockChain/Instances.hs | 110 ++++++++++++++++++++++++++--- src/Cooked/BlockChain/Run.hs | 36 +++++++++- src/Cooked/Effect/Log.hs | 2 +- src/Cooked/Effect/Override.hs | 2 +- src/Cooked/Effect/Params.hs | 86 +++++++++++----------- src/Cooked/Effect/Validation.hs | 6 +- src/Cooked/MockChain/Instances.hs | 31 ++++---- src/Cooked/MockChain/Run.hs | 3 +- src/Cooked/MockChain/Testing.hs | 6 +- src/Cooked/Pretty/MockChain.hs | 11 ++- src/Cooked/Runtime/Error.hs | 26 +++---- tests/Spec/ReferenceScripts.hs | 2 +- tests/Spec/Slot.hs | 2 +- 14 files changed, 278 insertions(+), 98 deletions(-) diff --git a/src/Cooked/BlockChain/Config.hs b/src/Cooked/BlockChain/Config.hs index 3eadfdbb1..a430491c8 100644 --- a/src/Cooked/BlockChain/Config.hs +++ b/src/Cooked/BlockChain/Config.hs @@ -1,4 +1,55 @@ +-- | This module exposes the configuration elements required to execute a block +-- run. This includes the initial parameters and a way of processing the results +-- of a run. module Cooked.BlockChain.Config - ( + ( -- * Initial blockchain configuration + BlockChainConf (..), + blockChainConfTemplate, + + -- * Blockchain return type + RawBlockChainReturn, + FunOnBlockChainResult, + displayBlockChainResult, ) where + +import Cardano.Api qualified as Cardano +import Cooked.Pretty +import Cooked.Runtime +import Data.Default +import Prettyprinter ((<+>)) +import Prettyprinter qualified as PP +import Prettyprinter.Render.Text qualified as PP + +-- | Raw return type of running a blockchain +type RawBlockChainReturn a = + (PrettyCookedOpts, (ChainIndex, Either ChainError a)) + +-- | The type of function handling the raw blockchain return within an IO +-- context. +type FunOnBlockChainResult a b = RawBlockChainReturn a -> IO b + +-- | A simple function handling the result of a blockchain run by displaying on +-- IO the returned value and resulting blockchain state. +displayBlockChainResult :: (Show a) => FunOnBlockChainResult a () +displayBlockChainResult (opts, (chainIndexToUtxoState -> UtxoState available consumed, res)) = do + PP.putDoc $ case res of + Left err -> "🔴 Error:" <+> prettyCookedOpt opts err + Right a -> "🟢 Success with returned value:" <+> PP.viaShow a + PP.putDoc $ "🗑️" <+> prettyCookedOpt opts consumed + PP.putDoc $ "💰" <+> prettyCookedOpt opts available + +-- | Configuration from which to run a blockchain +data BlockChainConf a b where + BlockChainConf :: + { bccConnectInfo :: Cardano.LocalNodeConnectInfo, + bccInitialChainIndex :: ChainIndex, + bccPrettyOpts :: PrettyCookedOpts, + bccFunOnResult :: RawBlockChainReturn a -> IO b + } -> + BlockChainConf a b + +-- | A basic template for a 'BlockChainConf'. It takes a connection info as a +-- parameter, and displays the result of the run directly in IO. +blockChainConfTemplate :: (Show a) => Cardano.LocalNodeConnectInfo -> BlockChainConf a () +blockChainConfTemplate connectInfo = BlockChainConf connectInfo def def displayBlockChainResult diff --git a/src/Cooked/BlockChain/Instances.hs b/src/Cooked/BlockChain/Instances.hs index 187a51fbc..091561d15 100644 --- a/src/Cooked/BlockChain/Instances.hs +++ b/src/Cooked/BlockChain/Instances.hs @@ -1,14 +1,23 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + -- | This module exposes the concrete instances to run a blockchain against a -- real node backend, mirroring 'Cooked.MockChain.Instances' which targets the -- emulated chain. module Cooked.BlockChain.Instances - ( FullBlockChainEffs, + ( -- * Direct, simple blockchain instance + DirectBlockChainEffs, + DirectBlockChain, + + -- * Blockchain instance with all effects + FullBlockChainEffs, FullBlockChain, ) where import Cardano.Api qualified as Cardano +import Cooked.BlockChain.Run import Cooked.Effect +import Cooked.Pretty.Options import Cooked.Runtime import Ledger qualified as P.Ledger import Polysemy @@ -17,24 +26,107 @@ import Polysemy.Fail import Polysemy.Reader import Polysemy.State --- | The most direct stack of effects to run a mockchain +-- | The most simple, straightforward stack of effects allowing to express +-- blockchain runs. This should be the preferred way of writing such runs. +type DirectBlockChainEffs = + '[ Validate, + Query, + Time, + Misc + ] + +-- | A blockchain computation built on top of the 'DirectBlockChainEffs' stack +-- of effects. +type DirectBlockChain a = Sem DirectBlockChainEffs a + +instance RunnableBlockChain DirectBlockChainEffs where + runBlockChain pcOpts index nodeConnectInfo = + runFinal + . embedToFinal + . failToEmbed + . runState pcOpts + . runState index + . runError + . mapError CEToCardanoError + . mapError CETooFarAway + . mapError CEAcquiringFailure + . mapError CEEraMismatch + . mapError CENodeToClientVersionError + . runReader nodeConnectInfo + . runBlockChainMisc + . runBlockChainLog + . runBlockChainParams + . runBlockChainTime + . runBlockChainQuery + . runBlockChainSubmit + . runChainValidate + . insertAt @7 + @'[ Reader Cardano.LocalNodeConnectInfo, + Error Cardano.UnsupportedNtcVersionError, + Error Cardano.EraMismatch, + Error Cardano.AcquiringFailure, + Error Cardano.PastHorizonException, + Error P.Ledger.ToCardanoError, + Error ChainError, + State ChainIndex, + State PrettyCookedOpts, + Fail, + Embed IO, + Final IO + ] + . insertAt @4 + @'[ Params, + Log + ] + . insertAt @1 + @'[ Submit + ] + +-- | The full stack of effects required to run a blockchain, including +-- sub-effects usually invisible to the user. type FullBlockChainEffs = '[ Validate, + Submit, Query, Time, - Misc, - Fail, Params, + Log, + Misc, + Reader Cardano.LocalNodeConnectInfo, Error Cardano.UnsupportedNtcVersionError, Error Cardano.EraMismatch, Error Cardano.AcquiringFailure, - Error ChainError, - Error P.Ledger.ToCardanoError, Error Cardano.PastHorizonException, - Reader Cardano.LocalNodeConnectInfo, + Error P.Ledger.ToCardanoError, + Error ChainError, State ChainIndex, - Embed IO + State PrettyCookedOpts, + Fail, + Embed IO, + Final IO ] --- | A mockchain computation built on top of the `DirectEffs` stack of effects +-- | A blockchain computation built on top of the `FullBlockChainEffs` stack of effects type FullBlockChain a = Sem FullBlockChainEffs a + +instance RunnableBlockChain FullBlockChainEffs where + runBlockChain pcOpts index nodeConnectInfo = + runFinal + . embedToFinal + . failToEmbed + . runState pcOpts + . runState index + . runError + . mapError CEToCardanoError + . mapError CETooFarAway + . mapError CEAcquiringFailure + . mapError CEEraMismatch + . mapError CENodeToClientVersionError + . runReader nodeConnectInfo + . runBlockChainMisc + . runBlockChainLog + . runBlockChainParams + . runBlockChainTime + . runBlockChainQuery + . runBlockChainSubmit + . runChainValidate diff --git a/src/Cooked/BlockChain/Run.hs b/src/Cooked/BlockChain/Run.hs index 2db8c32e9..ed8dc3513 100644 --- a/src/Cooked/BlockChain/Run.hs +++ b/src/Cooked/BlockChain/Run.hs @@ -2,6 +2,40 @@ -- real node backend, mirroring 'Cooked.MockChain.Runnable' which targets the -- emulated chain. module Cooked.BlockChain.Run - ( + ( -- * Running blockchains + RunnableBlockChain (..), + runBlockChainFromConf, + runBlockChainFromConfTemplate, ) where + +import Cardano.Api qualified as Cardano +import Cooked.BlockChain.Config +import Cooked.Pretty.Options +import Cooked.Runtime.State +import Polysemy + +-- | The class of effects that represent a blockchain run +class RunnableBlockChain effs where + -- | Runs a blockchain computation + runBlockChain :: PrettyCookedOpts -> ChainIndex -> Cardano.LocalNodeConnectInfo -> Sem effs a -> IO (RawBlockChainReturn a) + +-- | Runs a 'RunnableBlockChain' from an initial 'BlockChainConf' +runBlockChainFromConf :: + (RunnableBlockChain effs) => + BlockChainConf a b -> + Sem effs a -> + IO b +runBlockChainFromConf (BlockChainConf connectInfo chainIndex prettyOpts fun) comp = + runBlockChain prettyOpts chainIndex connectInfo comp >>= fun + +-- | Runs a 'RunnableBlockChain' from an initial default 'BlockChainConf' +runBlockChainFromConfTemplate :: + ( RunnableBlockChain effs, + Show a + ) => + Cardano.LocalNodeConnectInfo -> + Sem effs a -> + IO () +runBlockChainFromConfTemplate nodeInfo = + runBlockChainFromConf (blockChainConfTemplate nodeInfo) diff --git a/src/Cooked/Effect/Log.hs b/src/Cooked/Effect/Log.hs index 2a379751d..4365201dc 100644 --- a/src/Cooked/Effect/Log.hs +++ b/src/Cooked/Effect/Log.hs @@ -48,7 +48,7 @@ runMockChainLog = interpret $ \(LogEvent event) -> tell $ fromLogEntry event -- for each log entry. runBlockChainLog :: ( Members - '[ (Embed IO), + '[ Embed IO, State PrettyCookedOpts, State ChainIndex ] diff --git a/src/Cooked/Effect/Override.hs b/src/Cooked/Effect/Override.hs index afb907586..17bba1685 100644 --- a/src/Cooked/Effect/Override.hs +++ b/src/Cooked/Effect/Override.hs @@ -113,5 +113,5 @@ runMockChainOverride = interpret $ \case . P.Ledger.toPlutusIndex -- We update our internal map by adding the new outputs modify' $ addOutputs outputsList - -- Finally, we return the created utxos + -- Embedly, we return the created utxos return $ Map.fromList outputsList diff --git a/src/Cooked/Effect/Params.hs b/src/Cooked/Effect/Params.hs index a4bb257ff..5615b0212 100644 --- a/src/Cooked/Effect/Params.hs +++ b/src/Cooked/Effect/Params.hs @@ -62,49 +62,6 @@ data Params :: Effect where makeSem_ ''Params --- | The interpretation for the configuration effect with a stored --- 'EmulatorState' -runMockChainParams :: - (Member (State EmulatorState) effs) => - Sem (Params : effs) a -> - Sem effs a -runMockChainParams = interpret $ \case - GetParams -> gets $ Emulator.pEmulatorPParams . emulatorStateParams - GetNetworkId -> gets $ Emulator.pNetworkId . emulatorStateParams - GetEraHistory -> gets $ Emulator.emulatorEraHistory . emulatorStateParams - GetSystemStart -> gets $ Shelley.systemStart . Emulator.emulatorGlobals . emulatorStateParams - --- | Interpret the `Params` 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`). -runBlockChainParams :: - ( Members - '[ Embed IO, - Error Cardano.UnsupportedNtcVersionError, - Error Cardano.EraMismatch, - Error Cardano.AcquiringFailure, - Reader Cardano.LocalNodeConnectInfo - ] - effs - ) => - Sem (Params : effs) a -> - Sem effs a -runBlockChainParams = 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 Params effs) => @@ -210,3 +167,46 @@ txSkelDepositedValueInProposals TxSkel {txSkelProposals} = <&> Api.Lovelace . (toInteger (length txSkelProposals) *) . Api.getLovelace + +-- | The interpretation for the configuration effect with a stored +-- 'EmulatorState' +runMockChainParams :: + (Member (State EmulatorState) effs) => + Sem (Params : effs) a -> + Sem effs a +runMockChainParams = interpret $ \case + GetParams -> gets $ Emulator.pEmulatorPParams . emulatorStateParams + GetNetworkId -> gets $ Emulator.pNetworkId . emulatorStateParams + GetEraHistory -> gets $ Emulator.emulatorEraHistory . emulatorStateParams + GetSystemStart -> gets $ Shelley.systemStart . Emulator.emulatorGlobals . emulatorStateParams + +-- | Interpret the `Params` 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`). +runBlockChainParams :: + ( Members + '[ Embed IO, + Error Cardano.UnsupportedNtcVersionError, + Error Cardano.EraMismatch, + Error Cardano.AcquiringFailure, + Reader Cardano.LocalNodeConnectInfo + ] + effs + ) => + Sem (Params : effs) a -> + Sem effs a +runBlockChainParams = 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 diff --git a/src/Cooked/Effect/Validation.hs b/src/Cooked/Effect/Validation.hs index 5a9362ae2..c81394762 100644 --- a/src/Cooked/Effect/Validation.hs +++ b/src/Cooked/Effect/Validation.hs @@ -14,7 +14,7 @@ module Cooked.Effect.Validation validateTxSkel_, -- * Interpreting the effect - runMockChainValidate, + runChainValidate, ) where @@ -84,7 +84,7 @@ validateTxSkel_ = void . validateTxSkel -- | Interpretes the 'Validate' effects in terms of other effects, in -- particular 'Submit'. -runMockChainValidate :: +runChainValidate :: ( Members '[ Log, Query, @@ -99,7 +99,7 @@ runMockChainValidate :: ) => Sem (Validate : effs) a -> Sem effs a -runMockChainValidate = interpret $ \case +runChainValidate = interpret $ \case ValidateTxSkel txSkel -> do -- We fetch the skeleton options let TxSkelOpts {..} = txSkelOpts txSkel diff --git a/src/Cooked/MockChain/Instances.hs b/src/Cooked/MockChain/Instances.hs index ddcd694c5..0799bf4e1 100644 --- a/src/Cooked/MockChain/Instances.hs +++ b/src/Cooked/MockChain/Instances.hs @@ -23,7 +23,7 @@ -- balancing, is required. module Cooked.MockChain.Instances ( -- * Direct, simple mockchain instance - DirectEffs, + DirectMockChainEffs, DirectMockChain, -- * Staged mockchain instance with all effects @@ -71,7 +71,7 @@ import Polysemy.State import Polysemy.Writer -- | The most direct stack of effects to run a mockchain -type DirectEffs = +type DirectMockChainEffs = '[ Validate, Override, Query, @@ -80,10 +80,11 @@ type DirectEffs = Fail ] --- | A mockchain computation built on top of the `DirectEffs` stack of effects -type DirectMockChain a = Sem DirectEffs a +-- | A mockchain computation built on top of the `DirectMockChainEffs` stack of +-- effects +type DirectMockChain a = Sem DirectMockChainEffs a -instance RunnableMockChain DirectEffs where +instance RunnableMockChain DirectMockChainEffs where runMockChain emInit ciInit = (: []) . run @@ -93,14 +94,14 @@ instance RunnableMockChain DirectEffs where . runState emInit . runError . mapError CEToCardanoError - . runFailInChainError + . failToError CEFailure . runMockChainMisc . runMockChainParams . runMockChainTime . runMockChainQuery . runMockChainOverride . runMockChainSubmit - . runMockChainValidate + . runChainValidate . insertAt @1 @'[ Submit ] @@ -170,7 +171,7 @@ instance RunnableMockChain FullEffs where . runState emInit . runError . mapError CEToCardanoError - . runFailInChainError + . failToError CEFailure . runMockChainParams . runMockChainTime . runMockChainQuery @@ -179,7 +180,7 @@ instance RunnableMockChain FullEffs where . runModifyLocally . runMockChainOverride . runMockChainSubmit - . runMockChainValidate + . runChainValidate . insertAt @1 @'[ Submit ] @@ -199,8 +200,8 @@ type ExtendedStagedTweakEffs extraEff = -- | A tweak computation based on the `ExtendedStagedTweakEffs` stack of effects type ExtendedStagedTweak extraEff a = TypedTweak (ExtendedStagedTweakEffs extraEff) a --- | A stack of effects which allows everything allowed by `DirectEffs` with the --- addition of branching and `Ltl` modification with tweaks living in +-- | A stack of effects which allows everything allowed by `DirectMockChainEffs` +-- with the addition of branching and `Ltl` modification with tweaks living in -- `ExtendedStagedTweakEffs` type ExtendedStagedEffs extraEff = '[ ModifyGlobally (UntypedTweak (ExtendedStagedTweakEffs extraEff)), @@ -233,7 +234,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runState emInit . runError . mapError CEToCardanoError - . runFailInChainError + . failToError CEFailure . runMockChainParams . runMockChainTime . runMockChainQuery @@ -243,7 +244,7 @@ instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extr . runModifyLocally . runMockChainOverride . runMockChainSubmit - . runMockChainValidate + . runChainValidate . insertAt @1 @'[ Submit ] @@ -272,8 +273,8 @@ type StagedTweakEffs = ExtendedStagedTweakEffs (Bundle '[]) -- | A tweak computation based on the `StagedTweakEffs` stack of effects type StagedTweak a = TypedTweak StagedTweakEffs a --- | A stack of effects which allows everything allowed by `DirectEffs` with the --- addition of branching and `Ltl` modification with tweaks living in +-- | A stack of effects which allows everything allowed by `DirectMockChainEffs` +-- with the addition of branching and `Ltl` modification with tweaks living in -- `StagedTweakEffs` type StagedEffs = ExtendedStagedEffs (Bundle '[]) diff --git a/src/Cooked/MockChain/Run.hs b/src/Cooked/MockChain/Run.hs index f7f7016b1..7fd90a372 100644 --- a/src/Cooked/MockChain/Run.hs +++ b/src/Cooked/MockChain/Run.hs @@ -16,8 +16,7 @@ import Polysemy -- | The class of effects that represent a mockchain run class RunnableMockChain effs where - -- | Runs a computation from an initial `EmulatorState` and `ChainIndex`, - -- while returning a list of `RawMockChainReturn` + -- | Runs a mockchain computation runMockChain :: EmulatorState -> ChainIndex -> Sem effs a -> [RawMockChainReturn a] -- | Runs a `RunnableMockChain` from an initial `MockChainConf` diff --git a/src/Cooked/MockChain/Testing.hs b/src/Cooked/MockChain/Testing.hs index 4f1dc950b..b38311ef1 100644 --- a/src/Cooked/MockChain/Testing.hs +++ b/src/Cooked/MockChain/Testing.hs @@ -258,7 +258,7 @@ assertSameSets l r = -- * Data structure to test mockchain traces {-- - Note on properties over the log (or list of 'MockChainLogEntry'): our + Note on properties over the log (or list of 'ChainLogEntry'): our 'Test' structure does not directly embed a predicate over the log. Instead it is embedded in both the failure and success prediates. The reason is simple: the log is generated and accessible in both cases and thus it is @@ -662,7 +662,7 @@ isAtMostOfSize n1 n2 = -- * Specific properties over the log -- | Ensures a certain event has been emitted. This uses the constructor's name --- of the 'MockChainLogEntry' by relying on 'show' being lazy. +-- of the 'ChainLogEntry' by relying on 'show' being lazy. happened :: (IsProp prop) => String -> @@ -680,7 +680,7 @@ happened eventName _ log <> ")" -- | Ensures a certain event has not been emitted. This uses the constructor's --- name of the 'MockChainLogEntry' by relying on 'show' being lazy. +-- name of the 'ChainLogEntry' by relying on 'show' being lazy. didNotHappen :: (IsProp prop) => String -> LogProp prop didNotHappen eventName _ log | not (eventName `Set.member` Set.fromList (head . words . show <$> log)) = testSuccess didNotHappen eventName _ _ = diff --git a/src/Cooked/Pretty/MockChain.hs b/src/Cooked/Pretty/MockChain.hs index b333bf806..50905ad59 100644 --- a/src/Cooked/Pretty/MockChain.hs +++ b/src/Cooked/Pretty/MockChain.hs @@ -4,6 +4,7 @@ -- 'PrettyCookedMaybe' instances for data types returned by a @MockChain@ run. module Cooked.Pretty.MockChain () where +import Cardano.Api qualified as Cardano import Cooked.MockChain.Config import Cooked.Pretty.Class import Cooked.Pretty.Options @@ -111,7 +112,15 @@ instance PrettyCooked ChainError where <+> prettyCookedOpt opts txOutRef <+> "with script hash:" <+> prettyHash opts scriptHash - <+> "; the full script must be provided through a matching reference input." + <+> "; the full script must be provided" + prettyCookedOpt _ (CENodeToClientVersionError (Cardano.UnsupportedNtcVersionError current allowed)) = + "Unsupported query version:" <+> PP.viaShow current <+> "; allowed:" <+> PP.viaShow allowed + prettyCookedOpt _ (CEEraMismatch (Cardano.EraMismatch ledgerEra txEra)) = + "Era mismatch. Expected:" <+> PP.viaShow ledgerEra <+> ", got:" <+> PP.viaShow txEra + prettyCookedOpt _ (CEAcquiringFailure err) = + "Acquiring failure:" <+> PP.viaShow err + prettyCookedOpt _ (CETooFarAway err) = + "Unforseeable future:" <+> PP.viaShow err prettyCookedOpt _ (CEFailure msg) = "Failed with:" <+> PP.pretty msg instance PrettyCooked (Contextualized [ChainLogEntry]) where diff --git a/src/Cooked/Runtime/Error.hs b/src/Cooked/Runtime/Error.hs index 68b6fb7e9..8d08dde68 100644 --- a/src/Cooked/Runtime/Error.hs +++ b/src/Cooked/Runtime/Error.hs @@ -3,19 +3,14 @@ module Cooked.Runtime.Error ( -- * Mockchain errors BalancingError (..), ChainError (..), - - -- * Interpreting Fail into @Error ChainError@ - runFailInChainError, ) where +import Cardano.Api qualified as Cardano import Cooked.Skeleton.User import Cooked.Utilities.Aliases import Ledger.Tx qualified as P.Ledger import PlutusLedgerApi.V3 qualified as Api -import Polysemy -import Polysemy.Error -import Polysemy.Fail -- | Errors that can be produced during balancing data BalancingError @@ -58,15 +53,14 @@ data ChainError | -- | 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 CESpendingHashOnlyScript Api.TxOutRef Api.ScriptHash + | -- | The node does not support a specific versioned query + CENodeToClientVersionError Cardano.UnsupportedNtcVersionError + | -- | A mismatch exist between a submitted transaction and the node + CEEraMismatch Cardano.EraMismatch + | -- | Failure to get a response from querying a node + CEAcquiringFailure Cardano.AcquiringFailure + | -- | Looking to far into the future, beyond uncertainty + CETooFarAway Cardano.PastHorizonException | -- | Used to provide 'MonadFail' instances. CEFailure String - deriving (Show, Eq) - --- | Interpreting failures in terms of `ChainError` -runFailInChainError :: - forall effs a. - (Member (Error ChainError) effs) => - Sem (Fail : effs) a -> - Sem effs a -runFailInChainError = interpret $ - \(Fail s) -> throw $ CEFailure s + deriving (Show) diff --git a/tests/Spec/ReferenceScripts.hs b/tests/Spec/ReferenceScripts.hs index 3c18e45b9..04a2eb077 100644 --- a/tests/Spec/ReferenceScripts.hs +++ b/tests/Spec/ReferenceScripts.hs @@ -145,7 +145,7 @@ tests = ], testGroup "using reference scripts" - [ testCookedFromInitDistTemplate @DirectEffs "fail from transaction generation for missing reference scripts" $ + [ testCookedFromInitDistTemplate @DirectMockChainEffs "fail from transaction generation for missing reference scripts" $ mustFailTest ( do (Set.elemAt 0 -> consumedOref) <- diff --git a/tests/Spec/Slot.hs b/tests/Spec/Slot.hs index d39f3c669..409af0907 100644 --- a/tests/Spec/Slot.hs +++ b/tests/Spec/Slot.hs @@ -29,7 +29,7 @@ runSlot = run . runError . mapError CEToCardanoError - . runFailInChainError + . failToError CEFailure . evalState def . evalState def . runMockChainTime From 601fa47907e72014ef1604c0d39717e8c8d7b65b Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 13 Aug 2026 15:39:20 +0200 Subject: [PATCH 37/39] fixing missing imports + proper effect stacks names --- src/Cooked.hs | 2 +- src/Cooked/MockChain/Instances.hs | 30 +++++++++++++++--------------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Cooked.hs b/src/Cooked.hs index 5abc8458d..9ab486b8d 100644 --- a/src/Cooked.hs +++ b/src/Cooked.hs @@ -4,7 +4,7 @@ module Cooked (module X) where import Cooked.Attack as X import Cooked.Automation as X -import Cooked.BlockChain () +import Cooked.BlockChain as X import Cooked.Effect as X import Cooked.MockChain as X import Cooked.Pretty as X diff --git a/src/Cooked/MockChain/Instances.hs b/src/Cooked/MockChain/Instances.hs index 0799bf4e1..7d353cc3a 100644 --- a/src/Cooked/MockChain/Instances.hs +++ b/src/Cooked/MockChain/Instances.hs @@ -29,20 +29,20 @@ module Cooked.MockChain.Instances -- * Staged mockchain instance with all effects FullTweakEffs, FullTweak, - FullEffs, + FullMockChainEffs, FullMockChain, -- * Staged mockchain instance with minimal effects StagedTweakEffs, StagedTweak, - StagedEffs, + StagedMockChainEffs, StagedMockChain, -- * Staged mockchain instance with minimal effects and a custom effect InterpretAlone (..), ExtendedStagedTweakEffs, ExtendedStagedTweak, - ExtendedStagedEffs, + ExtendedStagedMockChainEffs, ExtendedStagedMockChain, ) where @@ -136,9 +136,9 @@ type FullTweakEffs = -- | A tweak computation based on the `FullTweakEffs` stack of effects type FullTweak a = TypedTweak FullTweakEffs a --- | A stack of effects which allows everything allowed by `StagedEffs` with the +-- | A stack of effects which allows everything allowed by `StagedMockChainEffs` with the -- addition of all the lower level effects required to interpret it. -type FullEffs = +type FullMockChainEffs = '[ ModifyGlobally (UntypedTweak FullTweakEffs), Validate, Override, @@ -158,10 +158,10 @@ type FullEffs = NonDet ] --- | A mockchain computation built on top of the `FullEffs` stack of effects -type FullMockChain a = Sem FullEffs a +-- | A mockchain computation built on top of the `FullMockChainEffs` stack of effects +type FullMockChain a = Sem FullMockChainEffs a -instance RunnableMockChain FullEffs where +instance RunnableMockChain FullMockChainEffs where runMockChain emInit ciInit = run . runNonDet @@ -203,7 +203,7 @@ type ExtendedStagedTweak extraEff a = TypedTweak (ExtendedStagedTweakEffs extraE -- | A stack of effects which allows everything allowed by `DirectMockChainEffs` -- with the addition of branching and `Ltl` modification with tweaks living in -- `ExtendedStagedTweakEffs` -type ExtendedStagedEffs extraEff = +type ExtendedStagedMockChainEffs extraEff = '[ ModifyGlobally (UntypedTweak (ExtendedStagedTweakEffs extraEff)), Validate, Override, @@ -215,16 +215,16 @@ type ExtendedStagedEffs extraEff = NonDet ] --- | A mockchain computation built on top of the `ExtendedStagedEffs` stack of +-- | A mockchain computation built on top of the `ExtendedStagedMockChainEffs` stack of -- effects -type ExtendedStagedMockChain extraEff a = Sem (ExtendedStagedEffs extraEff) a +type ExtendedStagedMockChain extraEff a = Sem (ExtendedStagedMockChainEffs extraEff) a -- | The class of effects that can be interpreted on their own on top of an -- arbitrary stack of effects class InterpretAlone eff where runInterpretAlone :: Sem (eff : effs) a -> Sem effs a -instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedEffs extraEff) where +instance (InterpretAlone extraEff) => RunnableMockChain (ExtendedStagedMockChainEffs extraEff) where runMockChain emInit ciInit = run . runNonDet @@ -276,10 +276,10 @@ type StagedTweak a = TypedTweak StagedTweakEffs a -- | A stack of effects which allows everything allowed by `DirectMockChainEffs` -- with the addition of branching and `Ltl` modification with tweaks living in -- `StagedTweakEffs` -type StagedEffs = ExtendedStagedEffs (Bundle '[]) +type StagedMockChainEffs = ExtendedStagedMockChainEffs (Bundle '[]) --- | A mockchain computation built on top of the `StagedEffs` stack of effects -type StagedMockChain a = Sem StagedEffs a +-- | A mockchain computation built on top of the `StagedMockChainEffs` stack of effects +type StagedMockChain a = Sem StagedMockChainEffs a instance InterpretAlone (Bundle '[]) where runInterpretAlone = runBundle From 76070c1a6ee982bfe5731a49823d6fb1797e29f1 Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 13 Aug 2026 15:47:43 +0200 Subject: [PATCH 38/39] adding Fail in DirectBlockChainEffs --- src/Cooked/BlockChain/Instances.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Cooked/BlockChain/Instances.hs b/src/Cooked/BlockChain/Instances.hs index 091561d15..d278d4cd0 100644 --- a/src/Cooked/BlockChain/Instances.hs +++ b/src/Cooked/BlockChain/Instances.hs @@ -32,7 +32,8 @@ type DirectBlockChainEffs = '[ Validate, Query, Time, - Misc + Misc, + Fail ] -- | A blockchain computation built on top of the 'DirectBlockChainEffs' stack @@ -60,6 +61,10 @@ instance RunnableBlockChain DirectBlockChainEffs where . runBlockChainQuery . runBlockChainSubmit . runChainValidate + . insertAt @17 + @'[ Embed IO, + Final IO + ] . insertAt @7 @'[ Reader Cardano.LocalNodeConnectInfo, Error Cardano.UnsupportedNtcVersionError, @@ -69,10 +74,7 @@ instance RunnableBlockChain DirectBlockChainEffs where Error P.Ledger.ToCardanoError, Error ChainError, State ChainIndex, - State PrettyCookedOpts, - Fail, - Embed IO, - Final IO + State PrettyCookedOpts ] . insertAt @4 @'[ Params, From e453242451f7438920ed0afbfaa7f684fb5c3077 Mon Sep 17 00:00:00 2001 From: mmontin Date: Thu, 13 Aug 2026 23:29:07 +0200 Subject: [PATCH 39/39] full refactoring of utxo searches. Finally the right one --- .../AutoFilling/ReferenceScripts.hs | 5 +- src/Cooked/Automation/Balancing.hs | 22 +- src/Cooked/Automation/GenerateTx/Body.hs | 7 +- .../Automation/GenerateTx/Collateral.hs | 7 +- src/Cooked/Effect/Query.hs | 442 ++++++++---------- tests/Spec/Attack/DatumHijacking.hs | 8 +- tests/Spec/Balancing.hs | 32 +- tests/Spec/InitialDistribution.hs | 6 +- tests/Spec/ReferenceScripts.hs | 9 +- 9 files changed, 250 insertions(+), 288 deletions(-) diff --git a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs index ec5d4b850..acb460a21 100644 --- a/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs +++ b/src/Cooked/Automation/AutoFilling/ReferenceScripts.hs @@ -39,7 +39,10 @@ updateRedeemedScript (toVScript -> vScript) txSkelRed@(TxSkelRedeemer {txSkelRedeemerAutoFill = True}) ) = do - oRefsInInputs <- getTxOutRefs $ allUtxosSearch $ ensureProperReferenceScript vScript + oRefsInInputs <- + allUtxos + >>= ensureAFoldIs (txSkelOutReferenceScriptHashAF % filtered (== Script.toScriptHash vScript)) + >>= retrieveTxOutRefs maybe -- We leave the redeemer unchanged if no reference input was found (return rs) diff --git a/src/Cooked/Automation/Balancing.hs b/src/Cooked/Automation/Balancing.hs index 65bffffc5..b08e3b970 100644 --- a/src/Cooked/Automation/Balancing.hs +++ b/src/Cooked/Automation/Balancing.hs @@ -114,13 +114,20 @@ 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) <$> getTxOutRefs (utxosAtSearch cUser ensureOnlyValueOutputs) + utxosAt cUser + >>= ensureOnlyValueOutputs + >>= retrieveTxOutRefs + >>= retrieve (Just . (,UserPubKey cUser)) -- 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 $ CEBalancingError MissingBalancingUser -- If a balancing wallet exists, we use it as collateral user - Just bUser -> Just . (,bUser) <$> getTxOutRefs (utxosAtSearch bUser ensureOnlyValueOutputs) + Just bUser -> + utxosAt bUser + >>= ensureOnlyValueOutputs + >>= retrieveTxOutRefs + >>= retrieve (Just . (,bUser)) -- At this point, the presence (or absence) of balancing user dictates -- whether the transaction should be automatically balanced or not. @@ -139,10 +146,11 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- utxos based on the associated policy balancingUtxos <- case txSkelOptBalancingUtxos txSkelOpts of - BalancingUtxosFromBalancingUser -> getUtxos $ utxosAtSearch bUser ensureOnlyValueOutputs + BalancingUtxosFromBalancingUser -> utxosAt bUser >>= ensureOnlyValueOutputs >>= retrieveUtxos BalancingUtxosFromSet utxos -> -- We resolve the given set of utxos - getUtxos (txSkelOutByRefSearch' utxos) + utxosFromRefs utxos + >>= retrieveUtxos -- We filter out those belonging to scripts, while throwing a -- warning if any was actually discarded. >>= filterAndWarn (const $ is (txSkelOutOwnerL % userPubKeyHashAT)) "They belong to scripts." @@ -166,6 +174,10 @@ balanceTxSkel skelUnbal@TxSkel {..} = do filterAndWarn f s l | (ok, toInteger . length -> koLength) <- Map.partitionWithKey f l = unless (koLength == 0) (logEvent $ CLogDiscardedUtxos koLength s) >> return ok + ensureOnlyValueOutputs = + ensureAFoldIsn't txSkelOutReferenceScriptAT + >=> ensureAFoldIsn't txSkelOutStakingCredentialAT + >=> ensureAFoldIsn't (txSkelOutDatumL % txSkelOutDatumKindAT) -- | Computes optimal fee for a given skeleton and balances it around those fees. -- This uses a dichotomic search for an optimal "balanceable around" fee. @@ -265,7 +277,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 <- getUtxos $ txSkelOutByRefSearch' collateralIns + collateralTxOuts <- utxosFromRefs collateralIns >>= retrieveUtxos -- 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 diff --git a/src/Cooked/Automation/GenerateTx/Body.hs b/src/Cooked/Automation/GenerateTx/Body.hs index 850fbde40..5e0f4ff84 100644 --- a/src/Cooked/Automation/GenerateTx/Body.hs +++ b/src/Cooked/Automation/GenerateTx/Body.hs @@ -107,9 +107,12 @@ txSkelToIndex :: txSkelToIndex txSkel mCollaterals = do -- We build the index of UTxOs which are known to this skeleton. This includes -- collateral inputs, inputs and reference inputs. - let collateralIns = maybe [] (Set.toList . fst) mCollaterals + let collateralIns = maybe Set.empty fst mCollaterals -- We retrieve all the outputs known to the skeleton - (knownTxORefs, knownTxOuts) <- unzip . Map.toList <$> lookupUtxos (Set.toList (txSkelKnownTxOutRefs txSkel) <> collateralIns) + (knownTxORefs, knownTxOuts) <- + utxosFromRefs (txSkelKnownTxOutRefs txSkel <> collateralIns) + >>= retrieveUtxos + >>= retrieve (unzip . Map.toList) -- We then compute their Cardano counterparts txOutL <- forM knownTxOuts toCardanoTxOut -- We build the index and handle the possible error diff --git a/src/Cooked/Automation/GenerateTx/Collateral.hs b/src/Cooked/Automation/GenerateTx/Collateral.hs index 0504438ef..1d4c081aa 100644 --- a/src/Cooked/Automation/GenerateTx/Collateral.hs +++ b/src/Cooked/Automation/GenerateTx/Collateral.hs @@ -12,7 +12,6 @@ import Cooked.Effect.Query import Cooked.Skeleton.Output import Cooked.Skeleton.Value import Cooked.Utilities.Aliases -import Data.Map qualified as Map import Data.Set qualified as Set import Ledger.Tx.CardanoAPI qualified as P.Ledger import Optics.Core @@ -48,7 +47,11 @@ toCollateralTriplet (Just (Set.toList -> collateralInsList, mReturnCollateral)) [] -> return Cardano.TxInsCollateralNone l -> fromEither $ Cardano.TxInsCollateral Cardano.AlonzoEraOnwardsConway <$> mapM P.Ledger.toCardanoTxIn l -- We collect the amount of lovelace in the collateral inputs - Api.Lovelace collateralInsLovelace <- foldOf (folded % txSkelOutValueL % valueLovelaceL) . Map.elems <$> lookupUtxos collateralInsList + Api.Lovelace collateralInsLovelace <- + utxosFromRefs collateralInsList + >>= extractAFold (txSkelOutValueL % valueLovelaceL) + >>= retrieveExtractedHeads + >>= retrieve (foldOf folded) -- We collect the amount of lovelace in the return collateral output let Api.Lovelace returnCollateralLovelace = maybe 0 (view (txSkelOutValueL % valueLovelaceL)) mReturnCollateral -- The total collateral is the difference between the two diff --git a/src/Cooked/Effect/Query.hs b/src/Cooked/Effect/Query.hs index c1ebf2b78..d8c9ed783 100644 --- a/src/Cooked/Effect/Query.hs +++ b/src/Cooked/Effect/Query.hs @@ -9,10 +9,35 @@ -- 'Cooked.Effect.Params.Params' effect, which this -- effect relies on during its own interpretation. module Cooked.Effect.Query - ( -- * The 'Query' effect - Query, + ( -- * Utxo searches types + RefinedOutputsList, + UtxoSearchResult, + utxosSearchResultUtxosI, + + -- * Retrieving pieces of @UtxoSearchResult@ + retrieve, + retrieveUtxos, + retrieveRefinedOutputs, + retrieveExtracts, + retrieveTxOutRefs, + retrieveExtractedHeads, + + -- * Extracting new information from UTxOs + extract, + extractPure, + extractAFold, + extractTotal, + extractPureTotal, + extractGetter, - -- * 'Query' interpreters + -- * Filtering some UTxOs out + ensure, + ensurePure, + ensureAFoldIs, + ensureAFoldIsn't, + + -- * The 'Query' effect and interpreters + Query, runMockChainQuery, runBlockChainQuery, @@ -26,7 +51,7 @@ module Cooked.Effect.Query utxosAt, txSkelOutByRef, utxosFromCardanoTx, - lookupUtxos, + utxosFromRefs, previewByRef, viewByRef, @@ -35,45 +60,6 @@ module Cooked.Effect.Query -- * Query fetching the current full constitution script getConstitutionScript, - - -- * UTxO searches - UtxoSearch, - beginSearch, - beginSearchPure, - - -- * Processing search result - RefinedOutputsList, - UtxoSearchResult, - utxosSearchResultUtxosI, - getUtxos, - getOutputsAndExtracts, - getExtracts, - getTxOutRefs, - - -- * Basic UTxO searches - utxosAtSearch, - allUtxosSearch, - txSkelOutByRefSearch, - txSkelOutByRefSearch', - - -- * Extracting new information from UTxOs - extract, - extractPure, - extractAFold, - extractTotal, - extractPureTotal, - extractGetter, - - -- * Filtering some UTxOs out - ensure, - ensurePure, - ensureAFoldIs, - ensureAFoldIsn't, - - -- * Cooked filters - ensureOnlyValueOutputs, - ensureVanillaOutputs, - ensureProperReferenceScript, ) where @@ -110,6 +96,144 @@ import Polysemy.Reader import Polysemy.State import Witherable (filterA, witherM) +-- | An heterogeneous list starting with a 'TxSkelOut' +type RefinedOutputsList els = HList (TxSkelOut ': els) + +-- | 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 els = Map Api.TxOutRef (RefinedOutputsList els) + +-- | 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 +-- output. The idea is to begin with a simple search and refine the search with +-- filters while appending new elements to the list. +type UtxoSearch effs els = Sem effs (UtxoSearchResult els) + +-- | Retrieves part of a 'UtxoSearchResult'. We define it on a more general +-- type, to allow for extracting values from basically anything, thus avoiding +-- annoying fmaps prepending sequences of utxo search operators bound with @>>=@ +retrieve :: + (els -> a) -> + (els -> Sem effs a) +retrieve f = return . f + +-- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` +retrieveUtxos :: + UtxoSearchResult els -> + Sem effs Utxos +retrieveUtxos = retrieve $ fmap hHead + +-- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` alongside the +-- extracted elements +retrieveRefinedOutputs :: + UtxoSearchResult els -> + Sem effs [RefinedOutputsList els] +retrieveRefinedOutputs = retrieve Map.elems + +-- | Retrieves the extracted elements from a `UtxoSearchResult` +retrieveExtracts :: + UtxoSearchResult els -> + Sem effs [HList els] +retrieveExtracts = retrieve $ Map.elems . fmap hTail + +-- | Retrieves the `Api.TxOutRef`s from a `UtxoSearchResult` +retrieveTxOutRefs :: + UtxoSearchResult els -> + Sem effs (Set Api.TxOutRef) +retrieveTxOutRefs = retrieve Map.keysSet + +-- | Retrieves the first extracted elements from a 'UtxoSearchResult' +retrieveExtractedHeads :: + UtxoSearchResult (a ': els) -> + Sem effs [a] +retrieveExtractedHeads = retrieve $ Map.elems . fmap (hHead . hTail) + +-- | 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)) -> + UtxoSearchResult els -> + UtxoSearch effs (b ': els) +extract extractFun = + witherM + ( \(HCons txSkelOut es) -> + fmap (HCons txSkelOut . (`HCons` es)) <$> extractFun txSkelOut + ) + +-- | Same as `extract`, but with a pure extraction function +extractPure :: + (TxSkelOut -> Maybe b) -> + UtxoSearchResult els -> + UtxoSearch effs (b ': els) +extractPure = extract . (return .) + +-- | Same as `extractPure`, using an affine fold to extract the element +extractAFold :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearchResult els -> + UtxoSearch effs (b ': els) +extractAFold = extractPure . preview + +-- | Same as `extract`, but with a total extraction function +extractTotal :: + (TxSkelOut -> Sem effs b) -> + UtxoSearchResult els -> + UtxoSearch effs (b ': els) +extractTotal = extract . (fmap Just .) + +-- | Same as `extract`, but with a pure and total extraction function +extractPureTotal :: + (TxSkelOut -> b) -> + UtxoSearchResult els -> + UtxoSearch effs (b ': els) +extractPureTotal = extractTotal . (return .) + +-- | Same as `extractPureTotal`, using a getter to extract the element +extractGetter :: + (Is k A_Getter) => + Optic' k is TxSkelOut b -> + UtxoSearchResult els -> + UtxoSearch effs (b ': els) +extractGetter = extractPureTotal . view + +-- | Ensures the outputs resulting from the search satisfy the given predicate +ensure :: + (TxSkelOut -> Sem effs Bool) -> + UtxoSearchResult els -> + UtxoSearch effs els +ensure filterF = filterA (filterF . hHead) + +-- | Same as `ensure`, but with a pure predicate +ensurePure :: + (TxSkelOut -> Bool) -> + UtxoSearchResult els -> + UtxoSearch effs els +ensurePure = ensure . (return .) + +-- | Ensures the outputs resulting from the search contain the focus of the +-- given affine fold +ensureAFoldIs :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearchResult els -> + UtxoSearch effs els +ensureAFoldIs = ensurePure . is + +-- | Ensures the outputs resulting from the search do not contain the focus of +-- the given affine fold +ensureAFoldIsn't :: + (Is k An_AffineFold) => + Optic' k is TxSkelOut b -> + UtxoSearchResult els -> + UtxoSearch effs els +ensureAFoldIsn't = ensurePure . isn't + -- | 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. This is the user-facing read effect; its interpreters @@ -118,8 +242,8 @@ import Witherable (filterA, witherM) -- fixed chain configuration. data Query :: Effect where TxSkelOutByRef :: Api.TxOutRef -> Query m TxSkelOut - AllUtxos :: Query m Utxos - UtxosAt :: (Script.ToAddress a) => a -> Query m Utxos + AllUtxos :: Query m (UtxoSearchResult '[]) + UtxosAt :: (Script.ToAddress a) => a -> Query m (UtxoSearchResult '[]) GetConstitutionScript :: Query m (Maybe VScript) GetCurrentReward :: (Script.ToCredential c) => c -> Query m (Maybe Api.Lovelace) @@ -161,7 +285,7 @@ txSkelInputValue = -- | Returns a list of all currently known outputs allUtxos :: (Member Query effs) => - Sem effs Utxos + Sem effs (UtxoSearchResult '[]) -- | Returns a list of all UTxOs at a certain address. utxosAt :: @@ -169,7 +293,7 @@ utxosAt :: Script.ToAddress cred ) => cred -> - Sem effs Utxos + Sem effs (UtxoSearchResult '[]) -- | Returns an output given a reference to it txSkelOutByRef :: @@ -185,21 +309,23 @@ txSkelOutByRef :: utxosFromCardanoTx :: (Member Query effs) => P.Ledger.CardanoTx -> - Sem effs [(Api.TxOutRef, TxSkelOut)] + Sem effs (UtxoSearchResult '[]) utxosFromCardanoTx = - mapM (\txOutRef -> (txOutRef,) <$> txSkelOutByRef txOutRef) + utxosFromRefs . fmap (P.Ledger.fromCardanoTxIn . snd) . P.Ledger.getCardanoTxOutRefs -- | 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 Query effs) => - [Api.TxOutRef] -> - Sem effs (Map Api.TxOutRef TxSkelOut) -lookupUtxos = +utxosFromRefs :: + ( Foldable f, + Member Query effs + ) => + f Api.TxOutRef -> + Sem effs (UtxoSearchResult '[]) +utxosFromRefs = foldM - (\m oRef -> flip (Map.insert oRef) m <$> txSkelOutByRef oRef) + (\m oRef -> flip (Map.insert oRef) m . hSingleton <$> txSkelOutByRef oRef) Map.empty -- | Retrieves an output and views a specific element out of it @@ -274,7 +400,7 @@ runMockChainQuery = interpret $ \case % itraversed % filtered snd % filtered (decide . fst) - % to fst + % to (hSingleton . fst) -- | Interpret the `Query` effect by talking to a deployed node -- through a `Cardano.LocalNodeConnectInfo` (socket path and network id) @@ -307,7 +433,7 @@ runBlockChainQuery = interpret $ \case TxSkelOutByRef oRef -> do txIn <- fromEither $ P.Ledger.toCardanoTxIn oRef utxo <- queryUtxosAndHandleErrors $ Cardano.QueryUTxOByTxIn $ Set.singleton txIn - maybe (throw $ CEUnknownOutRef oRef) return $ Map.lookup oRef utxo + maybe (throw $ CEUnknownOutRef oRef) (return . hHead) $ Map.lookup oRef utxo GetConstitutionScript -> do -- We retrieve the official optional script hash of the current constitution Cardano.Constitution _ mScriptHash <- @@ -346,7 +472,7 @@ runBlockChainQuery = interpret $ \case let newConstitution = listToMaybe $ [ script - | (_, preview txSkelOutReferenceScriptAT -> Just script) <- Map.toList utxo, + | (_, preview txSkelOutReferenceScriptAT . hHead -> Just script) <- Map.toList utxo, Script.toScriptHash script == Script.toScriptHash scriptHash ] modify' $ set chainIndexConstitutionL newConstitution @@ -378,7 +504,7 @@ runBlockChainQuery = interpret $ \case knownUtxos <- gets chainIndexOutputs return $ Map.mapWithKey - (\oRef txSkelOut -> maybe txSkelOut fst $ Map.lookup oRef knownUtxos) + (\oRef txSkelOut -> hSingleton $ maybe txSkelOut fst $ Map.lookup oRef knownUtxos) (Map.mapKeysMonotonic P.Ledger.fromCardanoTxIn $ convertUtxo <$> Cardano.unUTxO utxo) convertUtxo :: Cardano.TxOut Cardano.CtxUTxO Cardano.ConwayEra -> TxSkelOut convertUtxo (Cardano.TxOut (P.Ledger.toPlutusAddress -> (Api.Address cred stCred)) val dat refScript) = @@ -395,201 +521,3 @@ runBlockChainQuery = interpret $ \case (P.Ledger.fromCardanoValue $ P.Ledger.fromCardanoTxOutValue val) False (P.Ledger.fromCardanoReferenceScript refScript) - --- | 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, --- alongside an heterogeneous list starting with the output in question, --- followed by any element that was extracted during the search. -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 --- output. The idea is to begin with a simple search and refine the search with --- filters while appending new elements to the list. -type UtxoSearch effs elems = Sem effs (UtxoSearchResult elems) - --- | Wraps up a computation returning a `Utxos` into a `UtxoSearch` -beginSearch :: - Sem effs Utxos -> - UtxoSearch effs '[] -beginSearch = fmap $ review utxosSearchResultUtxosI - --- | Same as `beginSearch` with a pure input -beginSearchPure :: - Utxos -> - UtxoSearch effs '[] -beginSearchPure = beginSearch . return - --- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult` -getUtxos :: - Sem effs (UtxoSearchResult elems) -> - 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 [RefinedOutputsList elems] -getOutputsAndExtracts = fmap Map.elems - --- | Retrieves the extracted elements from a `UtxoSearchResult` -getExtracts :: - Sem effs (UtxoSearchResult elems) -> - Sem effs [HList elems] -getExtracts = fmap (Map.elems . fmap hTail) - --- | Retrieves the `Api.TxOutRef`s from a `UtxoSearchResult` -getTxOutRefs :: - Sem effs (UtxoSearchResult elems) -> - Sem effs (Set Api.TxOutRef) -getTxOutRefs = fmap Map.keysSet - --- | Searches for utxos at a given address with a given filter -utxosAtSearch :: - (Member Query effs, Script.ToAddress pkh) => - pkh -> - (UtxoSearch effs '[] -> UtxoSearch effs els) -> - UtxoSearch effs els -utxosAtSearch pkh filters = filters $ beginSearch $ utxosAt pkh - --- | Searches for all the known utxos with a given filter -allUtxosSearch :: - (Member Query 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 Query effs) => - Set Api.TxOutRef -> - (UtxoSearch effs '[] -> UtxoSearch effs els) -> - UtxoSearch effs els -txSkelOutByRefSearch utxos filters = - 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 Query effs) => - Set Api.TxOutRef -> - UtxoSearch effs '[] -txSkelOutByRefSearch' = (`txSkelOutByRefSearch` id) - --- | 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 = - (>>= witherM (\(HCons txSkelOut es) -> fmap (HCons txSkelOut . (`HCons` es)) <$> extractFun txSkelOut)) - --- | Same as `extract`, but with a pure extraction function -extractPure :: - (TxSkelOut -> Maybe b) -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractPure = extract . (return .) - --- | Same as `extractPure`, using an affine fold to extract the element -extractAFold :: - (Is k An_AffineFold) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractAFold = extractPure . preview - --- | Same as `extract`, but with a total extraction function -extractTotal :: - (TxSkelOut -> Sem effs b) -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractTotal = extract . (fmap Just .) - --- | Same as `extract`, but with a pure and total extraction function -extractPureTotal :: - (TxSkelOut -> b) -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractPureTotal = extractTotal . (return .) - --- | Same as `extractPureTotal`, using a getter to extract the element -extractGetter :: - (Is k A_Getter) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs (b ': els) -extractGetter = extractPureTotal . view - --- | Ensures the outputs resulting from the search satisfy the given predicate -ensure :: - (TxSkelOut -> Sem effs Bool) -> - UtxoSearch effs els -> - UtxoSearch effs els -ensure filterF comp = - comp >>= filterA (filterF . hHead) - --- | Same as `ensure`, but with a pure predicate -ensurePure :: - (TxSkelOut -> Bool) -> - UtxoSearch effs els -> - UtxoSearch effs els -ensurePure = ensure . (return .) - --- | Ensures the outputs resulting from the search contain the focus of the --- given affine fold -ensureAFoldIs :: - (Is k An_AffineFold) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs els -ensureAFoldIs = ensurePure . is - --- | Ensures the outputs resulting from the search do not contain the focus of --- the given affine fold -ensureAFoldIsn't :: - (Is k An_AffineFold) => - Optic' k is TxSkelOut b -> - UtxoSearch effs els -> - UtxoSearch effs els -ensureAFoldIsn't = ensurePure . isn't - --- | Ensures the outputs resulting from the search do not have a reference --- script, nor a staking credential, nor a datum -ensureOnlyValueOutputs :: - UtxoSearch effs els -> - UtxoSearch effs els -ensureOnlyValueOutputs = - ensureAFoldIsn't txSkelOutReferenceScriptAT - . ensureAFoldIsn't txSkelOutStakingCredentialAT - . ensureAFoldIsn't (txSkelOutDatumL % txSkelOutDatumKindAT) - --- | Same as 'ensureOnlyValueOutputs', but also ensures the searched outputs do not --- contain non-ADA assets. -ensureVanillaOutputs :: - UtxoSearch effs els -> - UtxoSearch effs els -ensureVanillaOutputs = - ensureAFoldIs (txSkelOutValueL % valueLovelaceP) - . ensureOnlyValueOutputs - --- | Ensures the outputs resulting from the search have the given script as a --- reference script -ensureProperReferenceScript :: - (Script.ToScriptHash s) => - s -> - UtxoSearch effs els -> - UtxoSearch effs els -ensureProperReferenceScript (Script.toScriptHash -> sHash) = - ensureAFoldIs (txSkelOutReferenceScriptHashAF % filtered (== sHash)) diff --git a/tests/Spec/Attack/DatumHijacking.hs b/tests/Spec/Attack/DatumHijacking.hs index 44eae99d4..dedfdac40 100644 --- a/tests/Spec/Attack/DatumHijacking.hs +++ b/tests/Spec/Attack/DatumHijacking.hs @@ -31,8 +31,12 @@ lockTxSkel o v = txLock :: Script.MultiPurposeScript DHContract -> StagedMockChain Api.TxOutRef txLock v = do - oRefs <- getTxOutRefs $ utxosAtSearch (wallet 1) $ ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` lockValue)) - head <$> validateTxSkelL (lockTxSkel (Set.elemAt 0 oRefs) v) + utxosAt (wallet 1) + >>= ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` lockValue)) + >>= retrieveTxOutRefs + >>= retrieve ((`lockTxSkel` v) . Set.elemAt 0) + >>= validateTxSkelL + >>= retrieve head relockTxSkel :: Script.MultiPurposeScript DHContract -> Api.TxOutRef -> TxSkel relockTxSkel v o = diff --git a/tests/Spec/Balancing.hs b/tests/Spec/Balancing.hs index 960a0ab61..77948d69a 100644 --- a/tests/Spec/Balancing.hs +++ b/tests/Spec/Balancing.hs @@ -95,23 +95,21 @@ testingBalancingTemplate toBobValue toAliceValue spendSearch balanceSearch colla aliceNonOnlyValueUtxos :: FullMockChain (Set Api.TxOutRef) aliceNonOnlyValueUtxos = - getTxOutRefs $ - utxosAtSearch alice $ - ensurePure $ \skel -> - is txSkelOutReferenceScriptAT skel - || is (txSkelOutDatumL % txSkelOutDatumKindAT) skel + utxosAt alice + >>= ensurePure (\skel -> is txSkelOutReferenceScriptAT skel || is (txSkelOutDatumL % txSkelOutDatumKindAT) skel) + >>= retrieveTxOutRefs aliceNAdaUtxos :: Integer -> FullMockChain (Set Api.TxOutRef) aliceNAdaUtxos n = - getTxOutRefs $ - utxosAtSearch alice $ - ensureAFoldIs (txSkelOutValueL % valueLovelaceL % filtered (== Api.Lovelace (n * 1_000_000))) + utxosAt alice + >>= ensureAFoldIs (txSkelOutValueL % valueLovelaceL % filtered (== Api.Lovelace (n * 1_000_000))) + >>= retrieveTxOutRefs aliceRefScriptUtxos :: FullMockChain (Set Api.TxOutRef) aliceRefScriptUtxos = - getTxOutRefs $ - utxosAtSearch alice $ - ensureAFoldIs txSkelOutReferenceScriptAT + utxosAt alice + >>= ensureAFoldIs txSkelOutReferenceScriptAT + >>= retrieveTxOutRefs emptySearch :: FullMockChain (Set Api.TxOutRef) emptySearch = return Set.empty @@ -172,7 +170,10 @@ balanceReduceFee = do reachingMagic :: FullMockChain () reachingMagic = do - bananaOutRefs <- getTxOutRefs $ utxosAtSearch alice $ ensureAFoldIs (txSkelOutValueL % filtered (banana 1 `Api.leq`)) + bananaOutRefs <- + utxosAt alice + >>= ensureAFoldIs (txSkelOutValueL % filtered (banana 1 `Api.leq`)) + >>= retrieveTxOutRefs validateTxSkel_ $ txSkelEmulatorTemplate { txSkelOutputs = [bob `receives` Value (Script.ada 106 <> banana 12)], @@ -649,7 +650,12 @@ tests = ( testingBalancingTemplate mempty mempty - (getTxOutRefs $ utxosAtSearch alice ensureOnlyValueOutputs) + ( utxosAt alice + >>= ensureAFoldIsn't txSkelOutReferenceScriptAT + >>= ensureAFoldIsn't txSkelOutStakingCredentialAT + >>= ensureAFoldIsn't (txSkelOutDatumL % txSkelOutDatumKindAT) + >>= retrieveTxOutRefs + ) emptySearch emptySearch False diff --git a/tests/Spec/InitialDistribution.hs b/tests/Spec/InitialDistribution.hs index d74c5060b..d65843b48 100644 --- a/tests/Spec/InitialDistribution.hs +++ b/tests/Spec/InitialDistribution.hs @@ -24,8 +24,10 @@ initialDistributionWithReferenceScript = : replicate 2 (bob `receives` Value (Script.ada 100)) getValueFromInitialDatum :: DirectMockChain [Integer] -getValueFromInitialDatum = do - fmap hHead <$> getExtracts (utxosAtSearch alice (extractAFold (txSkelOutDatumL % txSkelOutDatumTypedAT @Integer))) +getValueFromInitialDatum = + utxosAt alice + >>= extractAFold (txSkelOutDatumL % txSkelOutDatumTypedAT @Integer) + >>= retrieveExtractedHeads spendReferenceAlwaysTrueValidator :: DirectMockChain () spendReferenceAlwaysTrueValidator = do diff --git a/tests/Spec/ReferenceScripts.hs b/tests/Spec/ReferenceScripts.hs index 04a2eb077..9f437cb44 100644 --- a/tests/Spec/ReferenceScripts.hs +++ b/tests/Spec/ReferenceScripts.hs @@ -148,10 +148,11 @@ tests = [ testCookedFromInitDistTemplate @DirectMockChainEffs "fail from transaction generation for missing reference scripts" $ mustFailTest ( do - (Set.elemAt 0 -> consumedOref) <- - getTxOutRefs $ - utxosAtSearch (wallet 1) $ - ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` Script.lovelace 42_000_000)) + consumedOref <- + utxosAt (wallet 1) + >>= ensureAFoldIs (txSkelOutValueL % filtered (`Api.geq` Script.lovelace 42_000_000)) + >>= retrieveTxOutRefs + >>= retrieve (Set.elemAt 0) oref : _ <- validateTxSkelL txSkelEmulatorTemplate