From e33139fa9b5cff3688a543c10d831fd1794edad4 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Feb 2025 10:22:44 +0100 Subject: [PATCH 01/30] src compiles --- cabal.project | 19 +++-------- src/Cooked/Currencies.hs | 20 +++++------ src/Cooked/MockChain/Balancing.hs | 29 +++++++--------- src/Cooked/MockChain/GenerateTx/Body.hs | 4 ++- src/Cooked/MockChain/GenerateTx/Collateral.hs | 4 ++- src/Cooked/MockChain/GenerateTx/Input.hs | 4 +-- src/Cooked/MockChain/GenerateTx/Mint.hs | 34 ++++++++----------- src/Cooked/MockChain/GenerateTx/Output.hs | 2 +- src/Cooked/MockChain/GenerateTx/Witness.hs | 6 +--- src/Cooked/MockChain/MockChainSt.hs | 10 +++--- src/Cooked/ShowBS.hs | 13 ++++++- 11 files changed, 69 insertions(+), 76 deletions(-) diff --git a/cabal.project b/cabal.project index 3eb18d3f2..f42899951 100644 --- a/cabal.project +++ b/cabal.project @@ -10,8 +10,8 @@ package cardano-crypto-praos source-repository-package type: git - location: https://github.com/IntersectMBO/cardano-node-emulator/ - tag: 3bdb1f2a578226c1aa39fe09b8fb13e3a0be6d6a + location: https://github.com/tweag/cardano-node-emulator-forked/ + tag: 5dae9b411326e08a54042be75874eda6a60127f2 subdir: cardano-node-emulator plutus-ledger @@ -33,10 +33,9 @@ repository cardano-haskell-packages c00aae8461a256275598500ea0e187588c35a5d5d7454fb57eac18d9edb86a56 d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee --- See CONTRIBUTING.adoc for how to update index-state index-state: - , hackage.haskell.org 2024-06-12T10:10:17Z - , cardano-haskell-packages 2024-06-12T10:10:17Z + , hackage.haskell.org 2024-12-24T12:56:48Z + , cardano-haskell-packages 2025-01-08T16:35:32Z -- We never, ever, want this. write-ghc-environment-files: never @@ -59,12 +58,4 @@ package cardano-crypto-praos flags: -external-libsodium-vrf constraints: - cardano-api ^>= 8.46 - -source-repository-package - type: git - location: https://github.com/input-output-hk/quickcheck-contractmodel - tag: b19a7689a0d40ba3c7f91da87ef5fbcf20f3926c - subdir: - quickcheck-contractmodel - quickcheck-threatmodel + cardano-api ^>= 10.3 diff --git a/src/Cooked/Currencies.hs b/src/Cooked/Currencies.hs index 877fb5a4c..96e210651 100644 --- a/src/Cooked/Currencies.hs +++ b/src/Cooked/Currencies.hs @@ -37,9 +37,7 @@ import Plutus.Script.Utils.Typed qualified as Script import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api import PlutusTx qualified -import PlutusTx.Builtins.Class qualified as PlutusTx import PlutusTx.Prelude -import Prelude qualified as Haskell -- | Takes a minting policy and a language version and returns the associated -- currency symbol @@ -48,17 +46,17 @@ currencySymbolFromLanguageAndMP lang = Script.scriptCurrencySymbol . flip Script -- * Quick Values --- | Token name of a /quick/ asset class; prefixes the name with a @'q'@ to make +-- | Token name of a /quick/ asset class; prefixes the name with a @'Quick'@ to make -- it easy to distinguish between quick and permanent tokens. -quickTokenName :: Haskell.String -> Script.TokenName -quickTokenName = Script.TokenName . PlutusTx.stringToBuiltinByteString +quickTokenName :: BuiltinByteString -> Script.TokenName +quickTokenName = Script.TokenName . ("Quick" <>) -- | /Quick/ asset class from a token name -quickAssetClass :: Haskell.String -> Script.AssetClass +quickAssetClass :: BuiltinByteString -> Script.AssetClass quickAssetClass = Script.assetClass quickCurrencySymbol . quickTokenName -- | Constructor for /quick/ values from token name and amount -quickValue :: Haskell.String -> Integer -> Api.Value +quickValue :: BuiltinByteString -> Integer -> Api.Value quickValue = Script.assetClassValue . quickAssetClass {-# INLINEABLE mkQuickCurrencyPolicy #-} @@ -77,15 +75,15 @@ quickCurrencySymbol = currencySymbolFromLanguageAndMP Script.PlutusV3 quickCurre -- * Permanent values -- | Token name of a /permanent/ asset class -permanentTokenName :: Haskell.String -> Script.TokenName -permanentTokenName = Script.TokenName . PlutusTx.stringToBuiltinByteString +permanentTokenName :: BuiltinByteString -> Script.TokenName +permanentTokenName = Script.TokenName . ("Perma" <>) -- | /Permanent/ asset class from a token name -permanentAssetClass :: Haskell.String -> Script.AssetClass +permanentAssetClass :: BuiltinByteString -> Script.AssetClass permanentAssetClass = Script.assetClass permanentCurrencySymbol . permanentTokenName -- | Constructor for /Permanent/ values from token name and amount -permanentValue :: Haskell.String -> Integer -> Api.Value +permanentValue :: BuiltinByteString -> Integer -> Api.Value permanentValue = Script.assetClassValue . permanentAssetClass {-# INLINEABLE mkPermanentCurrencyPolicy #-} diff --git a/src/Cooked/MockChain/Balancing.hs b/src/Cooked/MockChain/Balancing.hs index 6c4612eee..9960a302a 100644 --- a/src/Cooked/MockChain/Balancing.hs +++ b/src/Cooked/MockChain/Balancing.hs @@ -10,6 +10,7 @@ where import Cardano.Api.Ledger qualified as Cardano import Cardano.Api.Shelley qualified as Cardano +import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator import Cardano.Node.Emulator.Internal.Node.Validation qualified as Emulator import Control.Monad @@ -31,6 +32,7 @@ import Data.Ratio qualified as Rat import Data.Set (Set) import Data.Set qualified as Set import Ledger.Tx.CardanoAPI qualified as Ledger +import Lens.Micro.Extras qualified as MicroLens import Optics.Core import Plutus.Script.Utils.Ada qualified as Script import Plutus.Script.Utils.Value qualified as Script @@ -141,20 +143,13 @@ balanceTxSkel skelUnbal@TxSkel {..} = do -- based on the current protocol parameters getMinAndMaxFee :: (MonadBlockChainBalancing m) => m (Fee, Fee) getMinAndMaxFee = do - -- Default parameters in case they are not present. It is unclear when/if this - -- could actually happen though. These default values have been taken from the - -- current default instance of the protocol parameters. - let defMaxTxExecutionUnits = - Cardano.ExecutionUnits {executionSteps = 10_000_000_000, executionMemory = 14_000_000} - defExecutionUnitPrices = - Cardano.ExecutionUnitPrices {priceExecutionSteps = 721 Rat.% 10_000_000, priceExecutionMemory = 577 Rat.% 10_000} -- Parameters necessary to compute the maximum possible fee for a transaction - params <- Emulator.pProtocolParams <$> getParams - let maxTxSize = toInteger $ Cardano.protocolParamMaxTxSize params - Emulator.Coin txFeePerByte = Cardano.protocolParamTxFeePerByte params - Emulator.Coin txFeeFixed = Cardano.protocolParamTxFeeFixed params - Cardano.ExecutionUnitPrices priceESteps priceEMem = fromMaybe defExecutionUnitPrices $ Cardano.protocolParamPrices params - Cardano.ExecutionUnits (toInteger -> eSteps) (toInteger -> eMem) = fromMaybe defMaxTxExecutionUnits $ Cardano.protocolParamMaxTxExUnits params + params <- Emulator.pEmulatorPParams <$> getParams + let maxTxSize = toInteger $ MicroLens.view Conway.ppMaxTxSizeL params + Emulator.Coin txFeePerByte = MicroLens.view Conway.ppMinFeeAL params + Emulator.Coin txFeeFixed = MicroLens.view Conway.ppMinFeeBL params + Cardano.Prices (Cardano.unboundRational -> priceESteps) (Cardano.unboundRational -> priceEMem) = MicroLens.view Conway.ppPricesL params + Cardano.ExUnits (toInteger -> eSteps) (toInteger -> eMem) = MicroLens.view Conway.ppMaxTxExUnitsL params -- Final fee accounts for the size of the transaction and the units consumed -- by the execution of scripts from the transaction let sizeFees = txFeeFixed + (maxTxSize * txFeePerByte) @@ -230,11 +225,13 @@ attemptBalancingAndCollaterals balancingWallet balancingUtxos fee mCollaterals s -- number of collateral inputs authorized by protocol parameters. collateralInsFromFees :: (MonadBlockChainBalancing m) => Fee -> Collaterals -> Wallet -> m Collaterals collateralInsFromFees fee collateralIns returnCollateralWallet = do + -- We retrieve the protocal parameters + params <- Emulator.pEmulatorPParams <$> getParams -- We retrieve the max number of collateral inputs, with a default of 10. In -- practice this will be around 3. - nbMax <- toInteger . fromMaybe 10 . Cardano.protocolParamMaxCollateralInputs . Emulator.pProtocolParams <$> getParams + let nbMax = toInteger $ MicroLens.view Conway.ppMaxCollateralInputsL params -- We retrieve the percentage to respect between fees and total collaterals - percentage <- toInteger . fromMaybe 100 . Cardano.protocolParamCollateralPercent . Emulator.pProtocolParams <$> getParams + let percentage = toInteger $ MicroLens.view Conway.ppCollateralPercentageL params -- We compute the total collateral to be associated to the transaction as a -- value. This will be the target value to be reached by collateral inputs. We -- add one because of ledger requirement which seem to round up this value. @@ -313,7 +310,7 @@ estimateTxSkelFee skel fee mCollaterals = do Left err -> throwError $ MCEGenerationError err Right txBodyContent -> return txBodyContent -- We create the actual body and send if for validation - txBody <- case Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway txBodyContent of + txBody <- case Cardano.createTransactionBody Cardano.ShelleyBasedEraConway txBodyContent of Left err -> throwError $ MCEGenerationError $ TxBodyError "Error creating body when estimating fees" err Right txBody -> return txBody -- We retrieve the estimate number of required witness in the transaction diff --git a/src/Cooked/MockChain/GenerateTx/Body.hs b/src/Cooked/MockChain/GenerateTx/Body.hs index 38655246b..455167d90 100644 --- a/src/Cooked/MockChain/GenerateTx/Body.hs +++ b/src/Cooked/MockChain/GenerateTx/Body.hs @@ -103,6 +103,8 @@ txSkelToBodyContent skel@TxSkel {..} | txSkelReferenceInputs <- txSkelReferenceT txCertificates = Cardano.TxCertificatesNone -- That's what plutus-apps does as well txScriptValidity = Cardano.TxScriptValidityNone -- That's what plutus-apps does as well txVotingProcedures = Nothing + txCurrentTreasuryValue = Nothing + txTreasuryDonation = Nothing return Cardano.TxBodyContent {..} -- | Generates a transaction for a skeleton. We first generate a body and we @@ -114,7 +116,7 @@ txSkelToCardanoTx txSkel = do -- We create the associated Shelley TxBody txBody@(Cardano.ShelleyTxBody a body c dats e f) <- - lift $ mapLeft (TxBodyError "generateTx :") $ Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway txBodyContent + lift $ mapLeft (TxBodyError "generateTx :") $ Cardano.createTransactionBody Cardano.ShelleyBasedEraConway txBodyContent -- There is a chance that the body is in need of additional data. This happens -- when the set of reference inputs contains hashed datums that will need to diff --git a/src/Cooked/MockChain/GenerateTx/Collateral.hs b/src/Cooked/MockChain/GenerateTx/Collateral.hs index 28a854922..02ac3d6ab 100644 --- a/src/Cooked/MockChain/GenerateTx/Collateral.hs +++ b/src/Cooked/MockChain/GenerateTx/Collateral.hs @@ -2,6 +2,7 @@ module Cooked.MockChain.GenerateTx.Collateral where import Cardano.Api qualified as Cardano import Cardano.Api.Shelley qualified as Cardano hiding (Testnet) +import Cardano.Ledger.Conway.Core qualified as Conway import Cardano.Node.Emulator.Internal.Node qualified as Emulator import Control.Monad import Control.Monad.Reader @@ -14,6 +15,7 @@ import Data.Maybe import Data.Set (Set) import Data.Set qualified as Set import Ledger.Tx.CardanoAPI qualified as Ledger +import Lens.Micro.Extras qualified as MicroLens import PlutusLedgerApi.V1.Value qualified as Api import PlutusLedgerApi.V3 qualified as Api import PlutusTx.Numeric qualified as PlutusTx @@ -65,7 +67,7 @@ toCollateralTriplet = do -- We retrieve the collateral percentage compared to fees. By default, we use -- 150% which is the current value in the parameters, although the default -- value should never be used here, as the call is supposed to always succeed. - collateralPercentage <- asks (toInteger . fromMaybe 150 . Cardano.protocolParamCollateralPercent . Emulator.pProtocolParams . params) + collateralPercentage <- asks (toInteger . MicroLens.view Conway.ppCollateralPercentageL . Emulator.pEmulatorPParams . params) -- The total collateral corresponds to the fees multiplied by the collateral -- percentage. We add 1 because the ledger apparently rounds up this value. coinTotalCollateral <- asks (Emulator.Coin . (+ 1) . (`div` 100) . (* collateralPercentage) . fee) diff --git a/src/Cooked/MockChain/GenerateTx/Input.hs b/src/Cooked/MockChain/GenerateTx/Input.hs index 9ee954920..09b78e6ab 100644 --- a/src/Cooked/MockChain/GenerateTx/Input.hs +++ b/src/Cooked/MockChain/GenerateTx/Input.hs @@ -39,11 +39,11 @@ toTxInAndWitness (txOutRef, txSkelRedeemer) = do Api.ScriptCredential (Api.ScriptHash scriptHash) -> do validator <- throwOnLookup "toTxInAndWitness: Unknown validator" (Script.ValidatorHash scriptHash) =<< asks managedValidators scriptDatum <- case datum of - Api.NoOutputDatum -> throwOnString "toTxInAndWitness: No datum found on script output" + Api.NoOutputDatum -> return $ Cardano.ScriptDatumForTxIn Nothing Api.OutputDatum _ -> return Cardano.InlineScriptDatum Api.OutputDatumHash datumHash -> do sDatum <- throwOnLookup "toTxInAndWitness: Unknown datum hash" datumHash =<< asks managedData - return $ Cardano.ScriptDatumForTxIn $ Ledger.toCardanoScriptData $ Api.getDatum sDatum + return $ Cardano.ScriptDatumForTxIn $ Just $ Ledger.toCardanoScriptData $ Api.getDatum sDatum Cardano.ScriptWitness Cardano.ScriptWitnessForSpending <$> liftTxGen (toScriptWitness validator txSkelRedeemer scriptDatum) throwOnToCardanoErrorOrApply "toTxInAndWitness: Unable to translate TxOutRef" diff --git a/src/Cooked/MockChain/GenerateTx/Mint.hs b/src/Cooked/MockChain/GenerateTx/Mint.hs index 32c469478..795e425fa 100644 --- a/src/Cooked/MockChain/GenerateTx/Mint.hs +++ b/src/Cooked/MockChain/GenerateTx/Mint.hs @@ -10,30 +10,26 @@ import Cooked.MockChain.GenerateTx.Witness import Cooked.Skeleton import Data.Map (Map) import Data.Map qualified as Map +import Data.Map.NonEmpty qualified as NEMap +import Data.Map.Strict qualified as SMap import Ledger.Tx.CardanoAPI qualified as Ledger import Plutus.Script.Utils.Scripts qualified as Script import PlutusLedgerApi.V3 qualified as Api +import PlutusTx.Builtins.Internal qualified as PlutusTx +import Test.QuickCheck.Modifiers (NonZero (NonZero)) type MintGen a = TxGen (Map Api.TxOutRef Api.TxOut) a -- | Converts the 'TxSkelMints' into a 'TxMintValue' toMintValue :: TxSkelMints -> MintGen (Cardano.TxMintValue Cardano.BuildTx Cardano.ConwayEra) -toMintValue mints = - if null mints - then return Cardano.TxMintNone - else do - let mintValue = txSkelMintsValue mints - mintVal <- - throwOnToCardanoError - ("toMintValue: Unable to translate minted value " <> show mintValue) - (Ledger.toCardanoValue mintValue) - (Map.fromList -> witnessMap) <- - forM (txSkelMintsToList mints) $ - \(policy, redeemer, _, _) -> do - policyId <- - throwOnToCardanoError - "toMintValue: Unable to translate minting policy hash" - (Ledger.toCardanoPolicyId (Script.mintingPolicyHash policy)) - mintWitness <- toScriptWitness policy redeemer Cardano.NoScriptDatumForMint - return (policyId, mintWitness) - return $ Cardano.TxMintValue Cardano.MaryEraOnwardsConway mintVal (Cardano.BuildTxWith witnessMap) +toMintValue mints | null mints = return Cardano.TxMintNone +toMintValue mints = fmap (Cardano.TxMintValue Cardano.MaryEraOnwardsConway . SMap.fromList) $ + forM (Map.toList mints) $ \(policy, (red, assets)) -> do + policyId <- + throwOnToCardanoError + "toMintValue: Unable to translate minting policy hash" + (Ledger.toCardanoPolicyId $ Script.mintingPolicyHash policy) + assetsMinted <- forM (Map.toList $ NEMap.toMap assets) $ \(Api.TokenName (PlutusTx.BuiltinByteString name), NonZero quantity) -> do + mintWitness <- toScriptWitness policy red Cardano.NoScriptDatumForMint + return (Cardano.AssetName name, Cardano.Quantity quantity, Cardano.BuildTxWith mintWitness) + return (policyId, assetsMinted) diff --git a/src/Cooked/MockChain/GenerateTx/Output.hs b/src/Cooked/MockChain/GenerateTx/Output.hs index 654923c1b..f7d95709b 100644 --- a/src/Cooked/MockChain/GenerateTx/Output.hs +++ b/src/Cooked/MockChain/GenerateTx/Output.hs @@ -43,6 +43,6 @@ toCardanoTxOut (Pays output) = do "toCardanoTxOut: Unable to resolve/transate a datum hash." $ Cardano.TxOutDatumHash Cardano.AlonzoEraOnwardsConway <$> Ledger.toCardanoScriptDataHash (Script.datumHash $ Api.Datum $ Api.toBuiltinData datum) - TxSkelOutDatum datum -> return $ Cardano.TxOutDatumInTx Cardano.AlonzoEraOnwardsConway $ toHashableScriptData datum + TxSkelOutDatum datum -> return $ Cardano.TxOutSupplementalDatum Cardano.AlonzoEraOnwardsConway $ toHashableScriptData datum TxSkelOutInlineDatum datum -> return $ Cardano.TxOutDatumInline Cardano.BabbageEraOnwardsConway $ toHashableScriptData datum return $ Cardano.TxOut address value datum $ Ledger.toCardanoReferenceScript (toVersionedScript <$> oRefScript) diff --git a/src/Cooked/MockChain/GenerateTx/Witness.hs b/src/Cooked/MockChain/GenerateTx/Witness.hs index 5b0549fd8..e7c587667 100644 --- a/src/Cooked/MockChain/GenerateTx/Witness.hs +++ b/src/Cooked/MockChain/GenerateTx/Witness.hs @@ -58,11 +58,7 @@ toPlutusScriptOrReferenceInput script (Just scriptOutRef) = do throwOnToCardanoError "toPlutusScriptOrReferenceInput: Unable to translate reference script utxo." (Ledger.toCardanoTxIn scriptOutRef) - scriptHash <- - throwOnToCardanoError - "toPlutusScriptOrReferenceInput: Unable to translate script hash of reference script." - (Ledger.toCardanoScriptHash refScriptHash) - return $ Cardano.PReferenceScript scriptTxIn (Just scriptHash) + return $ Cardano.PReferenceScript scriptTxIn -- | Translates a script with its associated redeemer and datum to a script -- witness. diff --git a/src/Cooked/MockChain/MockChainSt.hs b/src/Cooked/MockChain/MockChainSt.hs index 80aa56aa0..42ae04885 100644 --- a/src/Cooked/MockChain/MockChainSt.hs +++ b/src/Cooked/MockChain/MockChainSt.hs @@ -15,7 +15,7 @@ import Cooked.Output import Cooked.Skeleton import Data.Bifunctor (bimap) import Data.Default -import Data.Either.Combinators (mapLeft) +-- import Data.Either.Combinators (mapLeft) import Data.List (foldl') import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -222,15 +222,15 @@ utxoIndex0From (InitialDistribution initDist) = case mkBody of where mkBody :: Either GenerateTxError (Cardano.TxBody Cardano.ConwayEra) mkBody = do - value <- mapLeft (ToCardanoError "Value error") $ Ledger.toCardanoValue (foldl' (\v -> (v <>) . view txSkelOutValueL) mempty initDist) - let mintValue = flip (Cardano.TxMintValue Cardano.MaryEraOnwardsConway) (Cardano.BuildTxWith mempty) . Cardano.filterValue (/= Cardano.AdaAssetId) $ value + -- value <- mapLeft (ToCardanoError "Value error") $ Ledger.toCardanoValue (foldl' (\v -> (v <>) . view txSkelOutValueL) mempty initDist) + let -- mintValue = (Cardano.TxMintValue Cardano.MaryEraOnwardsConway) (Cardano.filterValue (/= Cardano.AdaAssetId) $ value) (Cardano.BuildTxWith mempty) theNetworkId = Cardano.Testnet $ Cardano.NetworkMagic 42 genesisKeyHash = Cardano.GenesisUTxOKeyHash $ Shelley.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194" inputs = [(Cardano.genesisUTxOPseudoTxIn theNetworkId genesisKeyHash, Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending)] outputs <- mapM (generateTxOut theNetworkId) initDist left (TxBodyError "Body error") $ - Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway $ - Ledger.emptyTxBodyContent {Cardano.txMintValue = mintValue, Cardano.txOuts = outputs, Cardano.txIns = inputs} + Cardano.createTransactionBody Cardano.ShelleyBasedEraConway $ + Ledger.emptyTxBodyContent {Cardano.txOuts = outputs, Cardano.txIns = inputs} utxoIndex0 :: Ledger.UtxoIndex utxoIndex0 = utxoIndex0From def diff --git a/src/Cooked/ShowBS.hs b/src/Cooked/ShowBS.hs index f6b09eb91..b988e778e 100644 --- a/src/Cooked/ShowBS.hs +++ b/src/Cooked/ShowBS.hs @@ -391,6 +391,15 @@ instance ShowBS Api.TxInfo where <> "treasury donation:" <> showBS txInfoTreasuryDonation +instance ShowBS Api.ScriptInfo where + {-# INLINEABLE showBS #-} + showBS (Api.MintingScript cs) = application1 "MintingScript" cs + showBS (Api.SpendingScript oref mDat) = application2 "SpendingScript" oref mDat + showBS (Api.RewardingScript stCred) = application1 "RewardingScript" stCred + showBS (Api.CertifyingScript nb txCert) = application2 "CertifyingScript" nb txCert + showBS (Api.VotingScript voter) = application1 "VotingScript" voter + showBS (Api.ProposingScript nb proposal) = application2 "ProposingScript" nb proposal + instance ShowBS Api.ScriptContext where {-# INLINEABLE showBS #-} showBS Api.ScriptContext {..} = @@ -398,5 +407,7 @@ instance ShowBS Api.ScriptContext where $ "Script context:" <> "Script Tx info:" <> showBS scriptContextTxInfo + <> "Script redeemer:" + <> showBS scriptContextRedeemer <> "Script purpose:" - <> showBS scriptContextPurpose + <> showBS scriptContextScriptInfo From c7b385d9deb03d8597b2526e20d59ee8a445e00d Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Feb 2025 11:02:28 +0100 Subject: [PATCH 02/30] tests compile --- tests/Cooked/ProposingScriptSpec.hs | 2 +- tests/Cooked/ReferenceInputsSpec.hs | 4 ++-- tests/Cooked/ReferenceScriptsSpec.hs | 4 ++-- tests/Cooked/WithdrawalsSpec.hs | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/Cooked/ProposingScriptSpec.hs b/tests/Cooked/ProposingScriptSpec.hs index 3977d004f..b1c084847 100644 --- a/tests/Cooked/ProposingScriptSpec.hs +++ b/tests/Cooked/ProposingScriptSpec.hs @@ -23,7 +23,7 @@ checkParameterChangeScript _ ctx = in case Api.ppGovernanceAction proposalProcedure of Api.ParameterChange _ (Api.ChangedParameters dat) _ -> let innerMap = PlutusTx.unsafeFromBuiltinData @(PlutusTx.Map PlutusTx.Integer PlutusTx.Integer) dat - in if innerMap PlutusTx.== PlutusTx.safeFromList [(0, 100)] then () else PlutusTx.traceError "wrong map" + in if PlutusTx.toList innerMap PlutusTx.== [(0, 100)] then () else PlutusTx.traceError "wrong map" _ -> PlutusTx.traceError "Wrong proposal procedure" checkProposingScript :: Script.Versioned Script.Script diff --git a/tests/Cooked/ReferenceInputsSpec.hs b/tests/Cooked/ReferenceInputsSpec.hs index e3668578b..671bef17e 100644 --- a/tests/Cooked/ReferenceInputsSpec.hs +++ b/tests/Cooked/ReferenceInputsSpec.hs @@ -50,7 +50,7 @@ instance Script.ValidatorTypes Foo where -- | Outputs can only be spent by pks whose hash is not the one in the -- datum. fooValidator :: FooDatum -> () -> Api.ScriptContext -> Bool -fooValidator (FooDatum pkh) _ (Api.ScriptContext txInfo _) = +fooValidator (FooDatum pkh) _ (Api.ScriptContext txInfo _ _) = PlutusTx.not PlutusTx.$ PlutusTx.elem pkh (Api.txInfoSignatories txInfo) fooTypedValidator :: Script.TypedValidator Foo @@ -63,7 +63,7 @@ fooTypedValidator = -- | Outputs can only be spent by pks who provide a reference input to -- a Foo in which they are mentioned (in an inlined datum). barValidator :: () -> () -> Api.ScriptContext -> Bool -barValidator _ _ (Api.ScriptContext txInfo _) = +barValidator _ _ (Api.ScriptContext txInfo _ _) = (PlutusTx.not . PlutusTx.null) (PlutusTx.filter f (Api.txInfoReferenceInputs txInfo)) where f :: Api.TxInInfo -> Bool diff --git a/tests/Cooked/ReferenceScriptsSpec.hs b/tests/Cooked/ReferenceScriptsSpec.hs index 29f868ef3..988346a35 100644 --- a/tests/Cooked/ReferenceScriptsSpec.hs +++ b/tests/Cooked/ReferenceScriptsSpec.hs @@ -28,7 +28,7 @@ requireSignerValidator = $$(PlutusTx.compile [||wrap||]) where val :: Api.PubKeyHash -> () -> () -> Api.ScriptContext -> Bool - val pkh _ _ (Api.ScriptContext txInfo _) = + val pkh _ _ (Api.ScriptContext txInfo _ _) = PlutusTx.traceIfFalse "the required signer is missing" PlutusTx.$ PlutusTx.elem pkh (Api.txInfoSignatories txInfo) @@ -43,7 +43,7 @@ requireRefScriptValidator = $$(PlutusTx.compile [||wrap||]) where val :: Api.ScriptHash -> () -> () -> Api.ScriptContext -> Bool - val expectedScriptHash _ _ (Api.ScriptContext txInfo _) = + val expectedScriptHash _ _ (Api.ScriptContext txInfo _ _) = PlutusTx.traceIfFalse "there is no reference input with the correct script hash" PlutusTx.$ PlutusTx.any ( \(Api.TxInInfo _ (Api.TxOut _ _ _ mRefScriptHash)) -> diff --git a/tests/Cooked/WithdrawalsSpec.hs b/tests/Cooked/WithdrawalsSpec.hs index 95eec8622..36770252a 100644 --- a/tests/Cooked/WithdrawalsSpec.hs +++ b/tests/Cooked/WithdrawalsSpec.hs @@ -16,9 +16,9 @@ checkWithdrawalScript red ctx = let scriptContext = PlutusTx.unsafeFromBuiltinData @Api.ScriptContext ctx withdrawals = Api.txInfoWdrl PlutusTx.$ Api.scriptContextTxInfo scriptContext quantity = PlutusTx.unsafeFromBuiltinData @Integer red - purpose = Api.scriptContextPurpose scriptContext + purpose = Api.scriptContextScriptInfo scriptContext in case purpose of - Api.Rewarding cred -> case PMap.toList withdrawals of + Api.RewardingScript cred -> case PMap.toList withdrawals of [(cred', Api.Lovelace n)] -> if cred PlutusTx.== cred' then From 4c6347c56e3d193134812af293f8669bf77dc7dc Mon Sep 17 00:00:00 2001 From: mmontin Date: Sun, 16 Feb 2025 23:55:23 +0100 Subject: [PATCH 03/30] not working --- cabal.project | 2 +- src/Cooked/Currencies.hs | 22 +++++++++++----------- tests/Cooked/BasicUsageSpec.hs | 3 +-- tests/Cooked/ReferenceScriptsSpec.hs | 8 ++++---- tests/Spec.hs | 26 +++++++++++++------------- 5 files changed, 30 insertions(+), 31 deletions(-) diff --git a/cabal.project b/cabal.project index f42899951..8676fe43f 100644 --- a/cabal.project +++ b/cabal.project @@ -11,7 +11,7 @@ package cardano-crypto-praos source-repository-package type: git location: https://github.com/tweag/cardano-node-emulator-forked/ - tag: 5dae9b411326e08a54042be75874eda6a60127f2 + tag: 4391a378c6f780484556a72a9df2f6b52675c571 subdir: cardano-node-emulator plutus-ledger diff --git a/src/Cooked/Currencies.hs b/src/Cooked/Currencies.hs index 96e210651..3e66d8b20 100644 --- a/src/Cooked/Currencies.hs +++ b/src/Cooked/Currencies.hs @@ -23,10 +23,10 @@ module Cooked.Currencies permanentAssetClass, permanentValue, quickCurrencyPolicy, - quickCurrencyPolicyV3, + quickCurrencyPolicyV2, quickCurrencySymbol, permanentCurrencyPolicy, - permanentCurrencyPolicyV3, + permanentCurrencyPolicyV2, permanentCurrencySymbol, currencySymbolFromLanguageAndMP, ) @@ -35,7 +35,7 @@ where import Plutus.Script.Utils.Scripts qualified as Script import Plutus.Script.Utils.Typed qualified as Script import Plutus.Script.Utils.Value qualified as Script -import PlutusLedgerApi.V3 qualified as Api +import PlutusLedgerApi.V2 qualified as Api import PlutusTx qualified import PlutusTx.Prelude @@ -49,7 +49,7 @@ currencySymbolFromLanguageAndMP lang = Script.scriptCurrencySymbol . flip Script -- | Token name of a /quick/ asset class; prefixes the name with a @'Quick'@ to make -- it easy to distinguish between quick and permanent tokens. quickTokenName :: BuiltinByteString -> Script.TokenName -quickTokenName = Script.TokenName . ("Quick" <>) +quickTokenName = Script.TokenName -- | /Quick/ asset class from a token name quickAssetClass :: BuiltinByteString -> Script.AssetClass @@ -66,17 +66,17 @@ mkQuickCurrencyPolicy _ _ = True quickCurrencyPolicy :: Script.MintingPolicy quickCurrencyPolicy = Script.mkMintingPolicyScript $$(PlutusTx.compile [||Script.mkUntypedMintingPolicy mkQuickCurrencyPolicy||]) -quickCurrencyPolicyV3 :: Script.Versioned Script.MintingPolicy -quickCurrencyPolicyV3 = Script.Versioned quickCurrencyPolicy Script.PlutusV3 +quickCurrencyPolicyV2 :: Script.Versioned Script.MintingPolicy +quickCurrencyPolicyV2 = Script.Versioned quickCurrencyPolicy Script.PlutusV2 quickCurrencySymbol :: Script.CurrencySymbol -quickCurrencySymbol = currencySymbolFromLanguageAndMP Script.PlutusV3 quickCurrencyPolicy +quickCurrencySymbol = currencySymbolFromLanguageAndMP Script.PlutusV2 quickCurrencyPolicy -- * Permanent values -- | Token name of a /permanent/ asset class permanentTokenName :: BuiltinByteString -> Script.TokenName -permanentTokenName = Script.TokenName . ("Perma" <>) +permanentTokenName = Script.TokenName -- | /Permanent/ asset class from a token name permanentAssetClass :: BuiltinByteString -> Script.AssetClass @@ -93,8 +93,8 @@ mkPermanentCurrencyPolicy _ _ = False permanentCurrencyPolicy :: Script.MintingPolicy permanentCurrencyPolicy = Script.mkMintingPolicyScript $$(PlutusTx.compile [||Script.mkUntypedMintingPolicy mkPermanentCurrencyPolicy||]) -permanentCurrencyPolicyV3 :: Script.Versioned Script.MintingPolicy -permanentCurrencyPolicyV3 = Script.Versioned permanentCurrencyPolicy Script.PlutusV3 +permanentCurrencyPolicyV2 :: Script.Versioned Script.MintingPolicy +permanentCurrencyPolicyV2 = Script.Versioned permanentCurrencyPolicy Script.PlutusV2 permanentCurrencySymbol :: Script.CurrencySymbol -permanentCurrencySymbol = currencySymbolFromLanguageAndMP Script.PlutusV3 permanentCurrencyPolicy +permanentCurrencySymbol = currencySymbolFromLanguageAndMP Script.PlutusV2 permanentCurrencyPolicy diff --git a/tests/Cooked/BasicUsageSpec.hs b/tests/Cooked/BasicUsageSpec.hs index 8c086fe9e..ad726b489 100644 --- a/tests/Cooked/BasicUsageSpec.hs +++ b/tests/Cooked/BasicUsageSpec.hs @@ -4,7 +4,6 @@ import Control.Monad import Cooked import Data.Default import Data.Map qualified as Map -import Plutus.Script.Utils.Scripts qualified as Script import Plutus.Script.Utils.Value qualified as Script import PlutusLedgerApi.V3 qualified as Api import Test.Tasty @@ -36,7 +35,7 @@ mintingQuickValue = void $ validateTxSkel $ txSkelTemplate - { txSkelMints = txSkelMintsFromList [(Script.Versioned quickCurrencyPolicy Script.PlutusV3, emptyTxSkelRedeemer, "banana", 10)], + { txSkelMints = txSkelMintsFromList [(quickCurrencyPolicyV2, emptyTxSkelRedeemer, "banana", 10)], txSkelOuts = [paysPK alice (quickValue "banana" 10)], txSkelSigners = [alice], txSkelOpts = def {txOptEnsureMinAda = True} diff --git a/tests/Cooked/ReferenceScriptsSpec.hs b/tests/Cooked/ReferenceScriptsSpec.hs index 988346a35..933de7804 100644 --- a/tests/Cooked/ReferenceScriptsSpec.hs +++ b/tests/Cooked/ReferenceScriptsSpec.hs @@ -260,20 +260,20 @@ tests = "referencing minting policies" [ testCase "succeed if given a reference minting policy" $ testSucceeds $ - referenceMint quickCurrencyPolicyV3 quickCurrencyPolicyV3 0 False, + referenceMint quickCurrencyPolicyV2 quickCurrencyPolicyV2 0 False, testCase "succeed if relying on automated finding of reference minting policy" $ testToProp $ - mustSucceedTest (referenceMint quickCurrencyPolicyV3 quickCurrencyPolicyV3 0 True) + mustSucceedTest (referenceMint quickCurrencyPolicyV2 quickCurrencyPolicyV2 0 True) `withJournalPred` (testBool . any (\case MCLogAddedReferenceScript {} -> True; _ -> False)), testCase "fail if given the wrong reference minting policy" $ testToProp $ - mustFailTest (referenceMint permanentCurrencyPolicyV3 quickCurrencyPolicyV3 0 False) + mustFailTest (referenceMint permanentCurrencyPolicyV2 quickCurrencyPolicyV2 0 False) `withErrorPred` \case MCEGenerationError (GenerateTxErrorGeneral err) -> err .==. "toPlutusScriptOrReferenceInput: Wrong reference script hash." _ -> testFailure, testCase "fail if referencing the wrong utxo" $ testToProp $ - mustFailTest (referenceMint quickCurrencyPolicyV3 quickCurrencyPolicyV3 1 False) + mustFailTest (referenceMint quickCurrencyPolicyV2 quickCurrencyPolicyV2 1 False) `withErrorPred` \case MCEGenerationError (GenerateTxErrorGeneral err) -> err .==. "toPlutusScriptOrReferenceInput: Can't resolve reference script utxo." _ -> testFailure diff --git a/tests/Spec.hs b/tests/Spec.hs index b8f7c8aea..3e2c163e7 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -18,17 +18,17 @@ main = defaultMain $ testGroup "cooked-validators" - [ BasicUsageSpec.tests, - MinAdaSpec.tests, - BalancingSpec.tests, - InlineDatumsSpec.tests, - ReferenceInputsSpec.tests, - ReferenceScriptsSpec.tests, - AttackSpec.tests, - TweakSpec.tests, - LtlSpec.tests, - MockChainSpec.tests, - InitDistribSpec.tests, - ProposingSpec.tests, - WithdrawalsSpec.tests + [ BasicUsageSpec.tests -- , + -- MinAdaSpec.tests, + -- BalancingSpec.tests, + -- InlineDatumsSpec.tests, + -- ReferenceInputsSpec.tests, + -- ReferenceScriptsSpec.tests, + -- AttackSpec.tests, + -- TweakSpec.tests, + -- LtlSpec.tests, + -- MockChainSpec.tests, + -- InitDistribSpec.tests, + -- ProposingSpec.tests, + -- WithdrawalsSpec.tests ] From ca199e84ecd278f91376a4442b8bcb7bae6389a2 Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 5 Mar 2025 15:52:42 +0100 Subject: [PATCH 04/30] adding dependencies directly here for now --- cabal.project | 16 +- cardano-node-emulator/CHANGELOG.md | 27 + .../cardano-node-emulator.cabal | 93 +++ ...er_PLT_1582_Cardano_Node_Emulator_Plain.md | 3 + ...erd.visscher_plt_5389_mtl_contractmodel.md | 4 + ...oerd.visscher_PLT_5512_emulator_logging.md | 4 + ...er_PLT_5620_node_emulator_mtl_query_fns.md | 3 + cardano-node-emulator/changelog.d/scriv.ini | 1 + .../src/Cardano/Node/Emulator.hs | 25 + .../src/Cardano/Node/Emulator/API.hs | 282 +++++++ .../src/Cardano/Node/Emulator/Generators.hs | 507 ++++++++++++ .../src/Cardano/Node/Emulator/Internal/API.hs | 122 +++ .../Cardano/Node/Emulator/Internal/Node.hs | 11 + .../Node/Emulator/Internal/Node/Chain.hs | 220 +++++ .../Node/Emulator/Internal/Node/Params.hs | 245 ++++++ .../Node/Emulator/Internal/Node/TimeSlot.hs | 179 ++++ .../Node/Emulator/Internal/Node/Validation.hs | 314 ++++++++ .../src/Cardano/Node/Emulator/LogMessages.hs | 60 ++ freer-extras/CHANGELOG.md | 7 + freer-extras/LICENSE | 53 ++ freer-extras/NOTICE | 14 + freer-extras/README.md | 8 + freer-extras/changelog.d/scriv.ini | 1 + freer-extras/freer-extras.cabal | 82 ++ .../src/Control/Monad/Freer/Extras.hs | 12 + .../src/Control/Monad/Freer/Extras/Delay.hs | 27 + .../src/Control/Monad/Freer/Extras/Log.hs | 410 ++++++++++ .../src/Control/Monad/Freer/Extras/Modify.hs | 206 +++++ .../Control/Monad/Freer/Extras/Pagination.hs | 111 +++ .../src/Control/Monad/Freer/Extras/State.hs | 22 + .../src/Control/Monad/Freer/Extras/Stream.hs | 29 + .../Monad/Freer/Extras/PaginationSpec.hs | 116 +++ freer-extras/test/Spec.hs | 18 + hie.yaml | 21 + plutus-ledger/ARCHITECTURE.adoc | 6 + plutus-ledger/CHANGELOG.md | 79 ++ plutus-ledger/LICENSE | 53 ++ plutus-ledger/NOTICE | 14 + plutus-ledger/README.md | 3 + ...cher_PLT_5294_replace_more_plutus_types.md | 9 + ...cher_PLT_5775_plutus-ledger_refactoring.md | 4 + plutus-ledger/changelog.d/scriv.ini | 1 + plutus-ledger/plutus-ledger.cabal | 184 +++++ plutus-ledger/src/Codec/CBOR/Extras.hs | 22 + plutus-ledger/src/Data/Aeson/Extras.hs | 53 ++ plutus-ledger/src/Data/Time/Units/Extra.hs | 34 + plutus-ledger/src/Ledger.hs | 24 + plutus-ledger/src/Ledger/Address.hs | 231 ++++++ plutus-ledger/src/Ledger/Address/Orphans.hs | 17 + plutus-ledger/src/Ledger/AddressMap.hs | 178 ++++ plutus-ledger/src/Ledger/Blockchain.hs | 76 ++ plutus-ledger/src/Ledger/Builtins/Orphans.hs | 32 + plutus-ledger/src/Ledger/CardanoWallet.hs | 210 +++++ .../src/Ledger/Credential/Orphans.hs | 28 + plutus-ledger/src/Ledger/Crypto.hs | 160 ++++ plutus-ledger/src/Ledger/Crypto/Orphans.hs | 26 + plutus-ledger/src/Ledger/DCert/Orphans.hs | 19 + plutus-ledger/src/Ledger/Index.hs | 228 ++++++ plutus-ledger/src/Ledger/Index/Internal.hs | 151 ++++ plutus-ledger/src/Ledger/Orphans.hs | 94 +++ plutus-ledger/src/Ledger/Scripts.hs | 52 ++ plutus-ledger/src/Ledger/Scripts/Orphans.hs | 129 +++ plutus-ledger/src/Ledger/Slot.hs | 102 +++ plutus-ledger/src/Ledger/Test.hs | 118 +++ plutus-ledger/src/Ledger/Tx.hs | 502 ++++++++++++ plutus-ledger/src/Ledger/Tx/CardanoAPI.hs | 156 ++++ .../src/Ledger/Tx/CardanoAPI/Internal.hs | 761 ++++++++++++++++++ plutus-ledger/src/Ledger/Tx/Internal.hs | 219 +++++ plutus-ledger/src/Ledger/Tx/Orphans.hs | 97 +++ plutus-ledger/src/Ledger/Tx/Orphans/V1.hs | 80 ++ plutus-ledger/src/Ledger/Tx/Orphans/V2.hs | 30 + plutus-ledger/src/Ledger/Typed/Scripts.hs | 43 + .../src/Ledger/Typed/Scripts/Orphans.hs | 16 + .../src/Ledger/Typed/Scripts/Validators.hs | 7 + plutus-ledger/src/Ledger/Typed/Tx.hs | 11 + plutus-ledger/src/Ledger/Typed/TypeUtils.hs | 7 + plutus-ledger/src/Ledger/Value/CardanoAPI.hs | 118 +++ plutus-ledger/src/Ledger/Value/Orphans.hs | 156 ++++ .../test/Ledger/Tx/CardanoAPISpec.hs | 157 ++++ plutus-ledger/test/Spec.hs | 205 +++++ plutus-script-utils/CHANGELOG.md | 25 + plutus-script-utils/CHANGELOG.rst | 11 + plutus-script-utils/LICENSE | 53 ++ plutus-script-utils/NOTICE | 14 + plutus-script-utils/README.adoc | 3 + plutus-script-utils/plutus-script-utils.cabal | 130 +++ .../src/Plutus/Script/Utils/Ada.hs | 168 ++++ .../src/Plutus/Script/Utils/Scripts.hs | 371 +++++++++ .../src/Plutus/Script/Utils/Typed.hs | 325 ++++++++ .../src/Plutus/Script/Utils/V1/Address.hs | 55 ++ .../src/Plutus/Script/Utils/V1/Contexts.hs | 29 + .../src/Plutus/Script/Utils/V1/Generators.hs | 56 ++ .../src/Plutus/Script/Utils/V1/Scripts.hs | 40 + .../src/Plutus/Script/Utils/V1/Tx.hs | 19 + .../Plutus/Script/Utils/V1/Typed/Scripts.hs | 132 +++ .../V1/Typed/Scripts/MonetaryPolicies.hs | 55 ++ .../Utils/V1/Typed/Scripts/StakeValidators.hs | 64 ++ .../Utils/V1/Typed/Scripts/Validators.hs | 159 ++++ .../src/Plutus/Script/Utils/V2/Address.hs | 55 ++ .../src/Plutus/Script/Utils/V2/Contexts.hs | 78 ++ .../src/Plutus/Script/Utils/V2/Generators.hs | 56 ++ .../src/Plutus/Script/Utils/V2/Scripts.hs | 40 + .../src/Plutus/Script/Utils/V2/Tx.hs | 19 + .../Plutus/Script/Utils/V2/Typed/Scripts.hs | 106 +++ .../V2/Typed/Scripts/MonetaryPolicies.hs | 57 ++ .../Utils/V2/Typed/Scripts/StakeValidators.hs | 60 ++ .../Utils/V2/Typed/Scripts/Validators.hs | 83 ++ .../src/Plutus/Script/Utils/V3/Address.hs | 55 ++ .../src/Plutus/Script/Utils/V3/Contexts.hs | 68 ++ .../src/Plutus/Script/Utils/V3/Scripts.hs | 98 +++ .../src/Plutus/Script/Utils/V3/Tx.hs | 19 + .../Plutus/Script/Utils/V3/Typed/Scripts.hs | 146 ++++ .../Utils/V3/Typed/Scripts/MultiPurpose.hs | 350 ++++++++ .../src/Plutus/Script/Utils/Value.hs | 146 ++++ .../src/Prettyprinter/Extras.hs | 38 + plutus-script-utils/test/Spec.hs | 20 + src/Cooked/Currencies.hs | 1 + src/Cooked/Skeleton.hs | 3 + src/Cooked/Validators.hs | 31 +- tests/Cooked/BalancingSpec.hs | 4 +- tests/Cooked/BasicUsageSpec.hs | 2 +- tests/Cooked/InlineDatumsSpec.hs | 303 ++++--- tests/Spec.hs | 28 +- 123 files changed, 11549 insertions(+), 181 deletions(-) create mode 100644 cardano-node-emulator/CHANGELOG.md create mode 100644 cardano-node-emulator/cardano-node-emulator.cabal create mode 100644 cardano-node-emulator/changelog.d/20230321_142001_sjoerd.visscher_PLT_1582_Cardano_Node_Emulator_Plain.md create mode 100644 cardano-node-emulator/changelog.d/20230331_165428_sjoerd.visscher_plt_5389_mtl_contractmodel.md create mode 100644 cardano-node-emulator/changelog.d/20230418_172119_sjoerd.visscher_PLT_5512_emulator_logging.md create mode 100644 cardano-node-emulator/changelog.d/20230523_153415_sjoerd.visscher_PLT_5620_node_emulator_mtl_query_fns.md create mode 120000 cardano-node-emulator/changelog.d/scriv.ini create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/API.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/Internal/API.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Chain.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs create mode 100644 cardano-node-emulator/src/Cardano/Node/Emulator/LogMessages.hs create mode 100644 freer-extras/CHANGELOG.md create mode 100644 freer-extras/LICENSE create mode 100644 freer-extras/NOTICE create mode 100644 freer-extras/README.md create mode 120000 freer-extras/changelog.d/scriv.ini create mode 100644 freer-extras/freer-extras.cabal create mode 100644 freer-extras/src/Control/Monad/Freer/Extras.hs create mode 100644 freer-extras/src/Control/Monad/Freer/Extras/Delay.hs create mode 100644 freer-extras/src/Control/Monad/Freer/Extras/Log.hs create mode 100644 freer-extras/src/Control/Monad/Freer/Extras/Modify.hs create mode 100644 freer-extras/src/Control/Monad/Freer/Extras/Pagination.hs create mode 100644 freer-extras/src/Control/Monad/Freer/Extras/State.hs create mode 100644 freer-extras/src/Control/Monad/Freer/Extras/Stream.hs create mode 100644 freer-extras/test/Control/Monad/Freer/Extras/PaginationSpec.hs create mode 100644 freer-extras/test/Spec.hs create mode 100644 plutus-ledger/ARCHITECTURE.adoc create mode 100644 plutus-ledger/CHANGELOG.md create mode 100644 plutus-ledger/LICENSE create mode 100644 plutus-ledger/NOTICE create mode 100644 plutus-ledger/README.md create mode 100644 plutus-ledger/changelog.d/20230412_134023_sjoerd.visscher_PLT_5294_replace_more_plutus_types.md create mode 100644 plutus-ledger/changelog.d/20230623_134342_sjoerd.visscher_PLT_5775_plutus-ledger_refactoring.md create mode 120000 plutus-ledger/changelog.d/scriv.ini create mode 100644 plutus-ledger/plutus-ledger.cabal create mode 100644 plutus-ledger/src/Codec/CBOR/Extras.hs create mode 100644 plutus-ledger/src/Data/Aeson/Extras.hs create mode 100644 plutus-ledger/src/Data/Time/Units/Extra.hs create mode 100644 plutus-ledger/src/Ledger.hs create mode 100644 plutus-ledger/src/Ledger/Address.hs create mode 100644 plutus-ledger/src/Ledger/Address/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/AddressMap.hs create mode 100644 plutus-ledger/src/Ledger/Blockchain.hs create mode 100644 plutus-ledger/src/Ledger/Builtins/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/CardanoWallet.hs create mode 100644 plutus-ledger/src/Ledger/Credential/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/Crypto.hs create mode 100644 plutus-ledger/src/Ledger/Crypto/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/DCert/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/Index.hs create mode 100644 plutus-ledger/src/Ledger/Index/Internal.hs create mode 100644 plutus-ledger/src/Ledger/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/Scripts.hs create mode 100644 plutus-ledger/src/Ledger/Scripts/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/Slot.hs create mode 100644 plutus-ledger/src/Ledger/Test.hs create mode 100644 plutus-ledger/src/Ledger/Tx.hs create mode 100644 plutus-ledger/src/Ledger/Tx/CardanoAPI.hs create mode 100644 plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs create mode 100644 plutus-ledger/src/Ledger/Tx/Internal.hs create mode 100644 plutus-ledger/src/Ledger/Tx/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/Tx/Orphans/V1.hs create mode 100644 plutus-ledger/src/Ledger/Tx/Orphans/V2.hs create mode 100644 plutus-ledger/src/Ledger/Typed/Scripts.hs create mode 100644 plutus-ledger/src/Ledger/Typed/Scripts/Orphans.hs create mode 100644 plutus-ledger/src/Ledger/Typed/Scripts/Validators.hs create mode 100644 plutus-ledger/src/Ledger/Typed/Tx.hs create mode 100644 plutus-ledger/src/Ledger/Typed/TypeUtils.hs create mode 100644 plutus-ledger/src/Ledger/Value/CardanoAPI.hs create mode 100644 plutus-ledger/src/Ledger/Value/Orphans.hs create mode 100644 plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs create mode 100644 plutus-ledger/test/Spec.hs create mode 100644 plutus-script-utils/CHANGELOG.md create mode 100644 plutus-script-utils/CHANGELOG.rst create mode 100644 plutus-script-utils/LICENSE create mode 100644 plutus-script-utils/NOTICE create mode 100644 plutus-script-utils/README.adoc create mode 100644 plutus-script-utils/plutus-script-utils.cabal create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/Ada.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/Typed.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Address.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Contexts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Generators.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Scripts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Tx.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Typed/Scripts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Typed/Scripts/MonetaryPolicies.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Typed/Scripts/StakeValidators.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/Typed/Scripts/Validators.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Address.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Contexts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Generators.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Scripts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Tx.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts/MonetaryPolicies.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts/StakeValidators.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/Typed/Scripts/Validators.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V3/Address.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V3/Contexts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V3/Scripts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V3/Tx.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V3/Typed/Scripts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V3/Typed/Scripts/MultiPurpose.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/Value.hs create mode 100644 plutus-script-utils/src/Prettyprinter/Extras.hs create mode 100644 plutus-script-utils/test/Spec.hs diff --git a/cabal.project b/cabal.project index 8676fe43f..542223650 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,9 @@ packages: . + cardano-node-emulator + plutus-ledger + plutus-script-utils + freer-extras package cooked-validators coverage: True @@ -7,17 +11,7 @@ package cooked-validators package cardano-crypto-praos flags: -external-libsodium-vrf - -source-repository-package - type: git - location: https://github.com/tweag/cardano-node-emulator-forked/ - tag: 4391a378c6f780484556a72a9df2f6b52675c571 - subdir: - cardano-node-emulator - plutus-ledger - plutus-script-utils - freer-extras - + -- Everything below this point has been copied from cardano-node-emulator cabal.project -- Custom repository for cardano haskell packages diff --git a/cardano-node-emulator/CHANGELOG.md b/cardano-node-emulator/CHANGELOG.md new file mode 100644 index 000000000..e2baa517b --- /dev/null +++ b/cardano-node-emulator/CHANGELOG.md @@ -0,0 +1,27 @@ + + +# 1.2.0 — 2023-03-03 + +## Removed + +- Removed `OpenApi.ToSchema` instance for `SlotConfig`. + +- Remove `estimateTransactionFee`, `signTx`, `fromPlutusTx`, `fromPlutusTxSigned`, `fromPlutusTxSigned'` as the `Tx` was removed from `plutus-ledger`. + +## Changed + +- The default utxo provider for balancing now selects bigger inputs first when adding new inputs, to reduce the number of inputs. + This was in particular a problem for collateral inputs, of which there can only be 3. + + +# 1.1.0 — 2023-01-12 + +## Added + +- Moved from `plutus-ledger` package: + - `Ledger.TimeSlot` to `Cardano.Node.Emulator.TimeSlot` + - `Ledger.Params` to `Cardano.Node.Emulator.Params` + - `Ledger.Generators` to `Cardano.Node.Emulator.Generators` + - `Ledger.Fee` to `Cardano.Node.Emulator.Fee` + - `Ledger.Validation` to `Cardano.Node.Emulator.Validation` + - `Wallet.Emulator.Chain` to `Cardano.Node.Emulator.Chain` diff --git a/cardano-node-emulator/cardano-node-emulator.cabal b/cardano-node-emulator/cardano-node-emulator.cabal new file mode 100644 index 000000000..b74793c4a --- /dev/null +++ b/cardano-node-emulator/cardano-node-emulator.cabal @@ -0,0 +1,93 @@ +cabal-version: 3.8 +name: cardano-node-emulator +version: 1.4.0.0 + +common lang + default-language: Haskell2010 + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + NamedFieldPuns + ScopedTypeVariables + StandaloneDeriving + + -- See Plutus Tx readme for why we need the following flags: + -- -fobject-code -fno-ignore-interface-pragmas and -fno-omit-interface-pragmas + ghc-options: + -Wall -Widentities -Wincomplete-record-updates -Wunused-packages + -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + -Wredundant-constraints -Wmissing-import-lists -fobject-code + -fno-ignore-interface-pragmas -fno-omit-interface-pragmas + -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt + PlutusTx.Plugin:defer-errors + + -- The limitation of plutus-tx-plugin + if (impl(ghc <9.6) || impl(ghc >=9.7)) + buildable: False + +library + import: lang + hs-source-dirs: src + exposed-modules: + Cardano.Node.Emulator + Cardano.Node.Emulator.API + Cardano.Node.Emulator.Generators + Cardano.Node.Emulator.Internal.API + Cardano.Node.Emulator.Internal.Node + Cardano.Node.Emulator.Internal.Node.Chain + Cardano.Node.Emulator.Internal.Node.Params + Cardano.Node.Emulator.Internal.Node.TimeSlot + Cardano.Node.Emulator.Internal.Node.Validation + Cardano.Node.Emulator.LogMessages + + -------------------- + -- Local components + -------------------- + build-depends: + , freer-extras ^>=1.4.0 + , plutus-ledger ^>=1.4.0 + + -------------------------- + -- Other IOG dependencies + -------------------------- + build-depends: + , cardano-api:{cardano-api, gen, internal} ^>=10.3 + , cardano-crypto + , cardano-ledger-alonzo + , cardano-ledger-api + , cardano-ledger-binary + , cardano-ledger-conway + , cardano-ledger-core + , cardano-ledger-shelley + , cardano-slotting + , ouroboros-consensus + , plutus-ledger-api >=1.0.0 + , plutus-tx >=1.0.0 + , sop-extras + , strict-sop-core + + ------------------------ + -- Non-IOG dependencies + ------------------------ + build-depends: + , aeson >=2 + , base >=4.9 && <5 + , bytestring + , containers + , data-default + , freer-simple + , hedgehog + , lens + , mtl + , prettyprinter >=1.1.0.1 + , sop-core + , text + , time diff --git a/cardano-node-emulator/changelog.d/20230321_142001_sjoerd.visscher_PLT_1582_Cardano_Node_Emulator_Plain.md b/cardano-node-emulator/changelog.d/20230321_142001_sjoerd.visscher_PLT_1582_Cardano_Node_Emulator_Plain.md new file mode 100644 index 000000000..6b7a9d60f --- /dev/null +++ b/cardano-node-emulator/changelog.d/20230321_142001_sjoerd.visscher_PLT_1582_Cardano_Node_Emulator_Plain.md @@ -0,0 +1,3 @@ +### Added + +- Added `Cardano.Node.Emulator.MTL`, a module that helps run the node emulator without the `Contract` monad. diff --git a/cardano-node-emulator/changelog.d/20230331_165428_sjoerd.visscher_plt_5389_mtl_contractmodel.md b/cardano-node-emulator/changelog.d/20230331_165428_sjoerd.visscher_plt_5389_mtl_contractmodel.md new file mode 100644 index 000000000..dcac33108 --- /dev/null +++ b/cardano-node-emulator/changelog.d/20230331_165428_sjoerd.visscher_plt_5389_mtl_contractmodel.md @@ -0,0 +1,4 @@ +### Added + +- Added `Cardano.Node.Emulator.MTL.Test`, with helpers for writing tests, including `quickcheck-contractmodel` tests. +- Added `currentSlot`, `awaitSlot` and `getParams` to `Cardano.Node.Emulator.MTL`. diff --git a/cardano-node-emulator/changelog.d/20230418_172119_sjoerd.visscher_PLT_5512_emulator_logging.md b/cardano-node-emulator/changelog.d/20230418_172119_sjoerd.visscher_PLT_5512_emulator_logging.md new file mode 100644 index 000000000..ba7b1b397 --- /dev/null +++ b/cardano-node-emulator/changelog.d/20230418_172119_sjoerd.visscher_PLT_5512_emulator_logging.md @@ -0,0 +1,4 @@ +### Added + +- Added logging methods to the MTL api: `logInfo`, `logDebug`, `logWarn` and `logError`. + diff --git a/cardano-node-emulator/changelog.d/20230523_153415_sjoerd.visscher_PLT_5620_node_emulator_mtl_query_fns.md b/cardano-node-emulator/changelog.d/20230523_153415_sjoerd.visscher_PLT_5620_node_emulator_mtl_query_fns.md new file mode 100644 index 000000000..1d42b5c57 --- /dev/null +++ b/cardano-node-emulator/changelog.d/20230523_153415_sjoerd.visscher_PLT_5620_node_emulator_mtl_query_fns.md @@ -0,0 +1,3 @@ +### Added + +- Added `utxoAtTxOutRef` and `lookupDatum` functions to `Cardano.Node.Emulator.MTL`. diff --git a/cardano-node-emulator/changelog.d/scriv.ini b/cardano-node-emulator/changelog.d/scriv.ini new file mode 120000 index 000000000..b4aeee9df --- /dev/null +++ b/cardano-node-emulator/changelog.d/scriv.ini @@ -0,0 +1 @@ +../../scriv.ini \ No newline at end of file diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator.hs b/cardano-node-emulator/src/Cardano/Node/Emulator.hs new file mode 100644 index 000000000..afa123388 --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | This module re-export the content needed to test a contract with the node emulator. +module Cardano.Node.Emulator + ( -- * Emulator contracts + module Cardano.Node.Emulator.API, + module Params, + + -- * Contract helpers + module Gen, + ) +where + +import Cardano.Node.Emulator.API +import Cardano.Node.Emulator.Generators as Gen + ( alwaysSucceedPolicy, + alwaysSucceedPolicyId, + emptyTxBodyContent, + knownAddresses, + knownPaymentKeys, + knownPaymentPrivateKeys, + knownPaymentPublicKeys, + someTokenValue, + ) +import Cardano.Node.Emulator.Internal.Node.Params as Params (Params) diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/API.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/API.hs new file mode 100644 index 000000000..fbaaa3cdf --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/API.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | If you want to run the node emulator without using the `Contract` monad, this module provides a simple MTL-based interface. +module Cardano.Node.Emulator.API + ( -- * Updating the blockchain + queueTx, + nextSlot, + currentSlot, + currentTimeRange, + awaitSlot, + awaitTime, + + -- * Querying the blockchain + utxosAt, + utxosAtPlutus, + utxoAtTxIn, + utxosAtTxIns, + utxoAtTxOutRef, + fundsAt, + lookupDatum, + getMemPoolEnv, + getLedgerState, + + -- * Transactions + signTx, + + -- * Logging + logDebug, + logInfo, + logWarn, + logError, + + -- * Types + EmulatorEra, + EmulatorState (EmulatorState), + esChainState, + esAddressMap, + esDatumMap, + EmulatedLedgerState, + ledgerEnv, + memPoolState, + EmulatorError (..), + EmulatorLogs, + EmulatorMsg (..), + L.LogMessage (..), + MonadEmulator, + EmulatorT, + EmulatorM, + emptyEmulatorState, + emptyEmulatorStateWithInitialDist, + Params (..), + getParams, + ) +where + +import Cardano.Api qualified as C +import Cardano.Ledger.Shelley.API + ( LedgerState, + MempoolEnv, + ) +import Cardano.Node.Emulator.Internal.API + ( EmulatorError (CustomError, ToCardanoError, ValidationError), + EmulatorLogs, + EmulatorM, + EmulatorState (EmulatorState), + EmulatorT, + MonadEmulator, + esAddressMap, + esChainState, + esDatumMap, + handleChain, + modifySlot, + processBlock, + ) +import Cardano.Node.Emulator.Internal.Node + ( EmulatedLedgerState, + Params (pConfig, pSlotConfig), + ledgerEnv, + memPoolState, + posixTimeToEnclosingSlot, + slotToBeginPOSIXTime, + slotToEndPOSIXTime, + ) +import Cardano.Node.Emulator.Internal.Node.Chain qualified as E + ( chainNewestFirst, + emptyChainState, + getCurrentSlot, + index, + ledgerState, + queueTx, + ) +import Cardano.Node.Emulator.Internal.Node.Params qualified as E (Params) +import Cardano.Node.Emulator.Internal.Node.Validation qualified as E + ( ledgerEnv, + memPoolState, + setUtxo, + unsafeMakeValid, + ) +import Cardano.Node.Emulator.LogMessages + ( EmulatorMsg (ChainEvent, GenericMsg, TxBalanceMsg), + TxBalanceMsg (SigningTx, SubmittingTx), + ) +import Control.Lens (use, (%~), (&), (.~), (<>~), (^.)) +import Control.Monad (void) +import Control.Monad.Freer.Extras.Log qualified as L +import Control.Monad.RWS.Class (ask, asks, get, tell) +import Data.Aeson (ToJSON (toJSON)) +import Data.Map (Map) +import Data.Map qualified as Map +import Ledger + ( CardanoAddress, + Datum, + DatumHash, + DecoratedTxOut, + POSIXTime, + Slot, + TxOutRef, + UtxoIndex, + ) +import Ledger.AddressMap qualified as AM +import Ledger.Index qualified as Index +import Ledger.Tx + ( CardanoTx, + TxOut, + addCardanoTxWitness, + cardanoTxOutValue, + getCardanoTxData, + toCtxUTxOTxOut, + toDecoratedTxOut, + ) +import Ledger.Tx.CardanoAPI + ( EmulatorEra, + fromCardanoTxIn, + fromPlutusIndex, + toCardanoTxIn, + ) + +emptyEmulatorState :: E.Params -> EmulatorState +emptyEmulatorState params = EmulatorState (E.emptyChainState params) mempty mempty + +emptyEmulatorStateWithInitialDist :: E.Params -> Map CardanoAddress C.Value -> EmulatorState +emptyEmulatorStateWithInitialDist params initialDist = + let tx = Index.createGenesisTransaction initialDist + vtx = E.unsafeMakeValid tx + index = Index.insertBlock [vtx] mempty + in emptyEmulatorState params + & esChainState . E.chainNewestFirst %~ ([vtx] :) + & esChainState . E.index .~ index + & esChainState . E.ledgerState %~ E.setUtxo params (fromPlutusIndex index) + & esAddressMap %~ AM.updateAllAddresses vtx + & esDatumMap <>~ getCardanoTxData tx + +getParams :: (MonadEmulator m) => m E.Params +getParams = ask + +-- | Queue the transaction, it will be processed when @nextSlot@ is called. +queueTx :: (MonadEmulator m) => CardanoTx -> m () +queueTx tx = do + logMsg L.Info $ TxBalanceMsg $ SubmittingTx tx + handleChain (E.queueTx tx) + +-- | Process the queued transactions and increase the slot number. +nextSlot :: (MonadEmulator m) => m () +nextSlot = void $ processBlock >> modifySlot succ + +-- | Get the current slot number of the emulated node. +currentSlot :: (MonadEmulator m) => m Slot +currentSlot = handleChain E.getCurrentSlot + +-- | Get the time range of the current slot of the emulated node. +currentTimeRange :: (MonadEmulator m) => m (POSIXTime, POSIXTime) +currentTimeRange = do + slotConfig <- asks pSlotConfig + slot <- currentSlot + pure + ( slotToBeginPOSIXTime slotConfig slot, + slotToEndPOSIXTime slotConfig slot + ) + +-- | Call `nextSlot` until the current slot number equals or exceeds the given slot number. +awaitSlot :: (MonadEmulator m) => Slot -> m () +awaitSlot s = do + c <- currentSlot + if s <= c + then pure () + else do + nextSlot + awaitSlot s + +-- | Call `nextSlot` until the given time has been reached. +awaitTime :: (MonadEmulator m) => POSIXTime -> m () +awaitTime t = do + slotConfig <- asks pSlotConfig + awaitSlot (posixTimeToEnclosingSlot slotConfig t + 1) + +-- | Query the unspent transaction outputs at the given address. +utxosAt :: (MonadEmulator m) => CardanoAddress -> m UtxoIndex +utxosAt addr = do + es <- get + pure $ C.UTxO $ Map.map (toCtxUTxOTxOut . snd) $ es ^. esAddressMap . AM.fundsAt addr + +-- | Query the unspent transaction outputs at the given address (using Plutus types). +utxosAtPlutus :: (MonadEmulator m) => CardanoAddress -> m (Map TxOutRef DecoratedTxOut) +utxosAtPlutus addr = do + es <- get + pure $ + Map.mapKeys fromCardanoTxIn $ + Map.mapMaybe (toDecoratedTxOut . snd) $ + es ^. esAddressMap . AM.fundsAt addr + +-- | Query the unspent transaction outputs at the given transaction inputs. +utxosAtTxIns :: (MonadEmulator m, Foldable f) => f C.TxIn -> m UtxoIndex +utxosAtTxIns txIns = do + idx <- use (esChainState . E.index) + pure $ foldMap (\txIn -> maybe mempty (Index.singleton txIn) $ Index.lookupUTxO txIn idx) txIns + +-- | Resolve the transaction input. +utxoAtTxIn :: (MonadEmulator m) => C.TxIn -> m (Maybe TxOut) +utxoAtTxIn txIn = Index.lookup txIn <$> use (esChainState . E.index) + +-- | Resolve the transaction output reference (using Plutus types). +utxoAtTxOutRef :: (MonadEmulator m) => TxOutRef -> m (Maybe DecoratedTxOut) +utxoAtTxOutRef ref = either (const $ pure Nothing) findTxOut (toCardanoTxIn ref) + where + findTxOut txIn = do + mTxOut <- utxoAtTxIn txIn + pure $ mTxOut >>= toDecoratedTxOut + +-- | Query the total value of the unspent transaction outputs at the given address. +fundsAt :: (MonadEmulator m) => CardanoAddress -> m C.Value +fundsAt addr = foldMap cardanoTxOutValue . C.unUTxO <$> utxosAt addr + +-- | Resolve a datum hash to an actual datum, if known. +lookupDatum :: (MonadEmulator m) => DatumHash -> m (Maybe Datum) +lookupDatum h = do + es <- get + pure $ Map.lookup h (es ^. esDatumMap) + +-- | Get the internal ledger state. +getLedgerState :: (MonadEmulator m) => m (LedgerState EmulatorEra) +getLedgerState = do + es <- get + pure $ es ^. esChainState . E.ledgerState . E.memPoolState + +-- | Get the internal mempool environment. +getMemPoolEnv :: (MonadEmulator m) => m (MempoolEnv EmulatorEra) +getMemPoolEnv = do + es <- get + pure $ es ^. esChainState . E.ledgerState . E.ledgerEnv + +-- | Sign a transaction with the given signatures. +signTx :: + (MonadEmulator m, Foldable f) => + -- | Signatures + f C.ShelleyWitnessSigningKey -> + CardanoTx -> + m CardanoTx +signTx witnesses tx = do + logMsg L.Info $ TxBalanceMsg $ SigningTx tx + pure $ foldr addCardanoTxWitness tx witnesses + +-- | Log any message +logMsg :: (MonadEmulator m) => L.LogLevel -> EmulatorMsg -> m () +logMsg l = tell . pure . L.LogMessage l + +-- | Log a message at the 'Debug' level +logDebug :: (ToJSON a, MonadEmulator m) => a -> m () +logDebug = logMsg L.Debug . GenericMsg . toJSON + +-- | Log a message at the 'Info' level +logInfo :: (ToJSON a, MonadEmulator m) => a -> m () +logInfo = logMsg L.Info . GenericMsg . toJSON + +-- | Log a message at the 'Warning' level +logWarn :: (ToJSON a, MonadEmulator m) => a -> m () +logWarn = logMsg L.Warning . GenericMsg . toJSON + +-- | Log a message at the 'Error' level +logError :: (ToJSON a, MonadEmulator m) => a -> m () +logError = logMsg L.Error . GenericMsg . toJSON diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs new file mode 100644 index 000000000..f87e89e28 --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs @@ -0,0 +1,507 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Generators for constructing blockchains and transactions for use in property-based testing. +module Cardano.Node.Emulator.Generators + ( -- * Mockchain + Mockchain (..), + genMockchain, + genMockchain', + emptyChain, + GeneratorModel (..), + generatorModel, + + -- * Transactions + genValidTransaction, + genValidTransactionBody, + genValidTransaction', + genValidTransactionSpending, + genValidTransactionSpending', + genInitialTransaction, + makeTx, + + -- * Assertions + assertValid, + + -- * Time + genInterval, + genSlotRange, + genTimeRange, + genSlot, + genPOSIXTime, + genSlotConfig, + + -- * Etc. + failOnCardanoError, + genPolicyId, + genAssetId, + Gen.genAssetName, + genSingleton, + genValue, + genValueNonNegative, + genSizedByteString, + genSeed, + genPassphrase, + splitVal, + validateMockchain, + signAll, + CW.knownAddresses, + CW.knownPaymentPublicKeys, + CW.knownPaymentPrivateKeys, + CW.knownPaymentKeys, + knownXPrvs, + alwaysSucceedPolicy, + alwaysSucceedPolicyId, + someTokenValue, + Tx.emptyTxBodyContent, + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Crypto.Wallet qualified as Crypto +import Cardano.Ledger.Api.PParams (ppMaxCollateralInputsL) +import Cardano.Node.Emulator.Internal.Node.Params (Params (pSlotConfig), testnet) +import Cardano.Node.Emulator.Internal.Node.TimeSlot (SlotConfig) +import Cardano.Node.Emulator.Internal.Node.TimeSlot qualified as TimeSlot +import Cardano.Node.Emulator.Internal.Node.Validation + ( Coin (Coin), + initialState, + setUtxo, + updateSlot, + validateCardanoTx, + ) +import Control.Lens (view) +import Control.Monad (guard, replicateM) +import Data.Bifunctor (Bifunctor (first)) +import Data.ByteString qualified as BS +import Data.Default (Default (def), def) +import Data.Foldable (fold, foldl') +import Data.Function ((&)) +import Data.Functor (($>)) +import Data.List (sort) +import Data.List qualified as List +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe, isNothing) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.String (fromString) +import GHC.Exts (fromList) +import GHC.Stack (HasCallStack) +import Hedgehog (Gen, MonadGen, MonadTest, Range) +import Hedgehog qualified as H +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Ledger + ( CardanoTx (CardanoEmulatorEraTx), + Interval, + POSIXTime (POSIXTime, getPOSIXTime), + POSIXTimeRange, + Passphrase (Passphrase), + PaymentPrivateKey (unPaymentPrivateKey), + PaymentPubKey, + Slot (Slot), + SlotRange, + TxOut, + ValidationErrorInPhase, + ValidationPhase (Phase1, Phase2), + ValidationResult (FailPhase1, FailPhase2), + addCardanoTxWitness, + createGenesisTransaction, + minLovelaceTxOutEstimated, + pubKeyAddress, + toWitness, + txOutValue, + ) +import Ledger.CardanoWallet qualified as CW +import Ledger.Scripts qualified as Script +import Ledger.Tx qualified as Tx +import Ledger.Tx.CardanoAPI qualified as LC +import Ledger.Value.CardanoAPI qualified as Value +import Numeric.Natural (Natural) +import PlutusLedgerApi.V1 qualified as V1 +import PlutusLedgerApi.V1.Interval qualified as Interval +import PlutusTx (toData) +import Test.Gen.Cardano.Api.Typed qualified as Gen + +-- | Attach signatures of all known private keys to a transaction. +signAll :: CardanoTx -> CardanoTx +signAll tx = + foldl' (flip addCardanoTxWitness) tx $ + fmap toWitness CW.knownPaymentPrivateKeys + +-- | The parameters for the generators in this module. +data GeneratorModel = GeneratorModel + { -- | Value created at the beginning of the blockchain. + gmInitialBalance :: !(Map PaymentPubKey Coin), + -- | Public keys that are to be used for generating transactions. + gmPubKeys :: !(Set PaymentPubKey), + gmMaxCollateralInputs :: !(Maybe Natural) + } + deriving (Show) + +-- | A generator model with some sensible defaults. +generatorModel :: GeneratorModel +generatorModel = + let vl = Coin $ 1_000_000 * 100 + pubKeys = CW.knownPaymentPublicKeys + in GeneratorModel + { gmInitialBalance = Map.fromList $ map (,vl) pubKeys, + gmPubKeys = Set.fromList pubKeys, + gmMaxCollateralInputs = Just $ view (ppMaxCollateralInputsL @LC.EmulatorEra) def + } + +-- | Blockchain for testing the emulator implementation and traces. +-- +-- To avoid having to rely on functions from the implementation of +-- plutus-ledger (in particular, 'Ledger.Tx.unspentOutputs') we note the +-- unspent outputs of the chain when it is first created. +data Mockchain = Mockchain + { mockchainInitialTxPool :: [CardanoTx], + mockchainUtxo :: Map C.TxIn TxOut, + mockchainParams :: Params + } + deriving (Show) + +-- | The empty mockchain. +emptyChain :: Mockchain +emptyChain = Mockchain [] Map.empty def + +-- | Generate a mockchain. +-- +-- TODO: Generate more than 1 txn +genMockchain' :: + GeneratorModel -> + Gen Mockchain +genMockchain' gm = do + slotCfg <- genSlotConfig + (txn, ot) <- genInitialTransaction gm + let params = def {pSlotConfig = slotCfg} + -- There is a problem that txId of emulator tx and tx of cardano tx are different. + -- We convert the emulator tx to cardano tx here to get the correct transaction id + -- because later we anyway will use the converted cardano tx so the utxo should match it. + tid = Tx.getCardanoTxId txn + pure + Mockchain + { mockchainInitialTxPool = [txn], + mockchainUtxo = Map.fromList $ first (C.TxIn tid . C.TxIx) <$> zip [0 ..] ot, + mockchainParams = params + } + +-- | Generate a mockchain using the default 'GeneratorModel'. +genMockchain :: Gen Mockchain +genMockchain = genMockchain' generatorModel + +-- | A transaction with no inputs that mints some value (to be used at the +-- beginning of a blockchain). +genInitialTransaction :: + GeneratorModel -> + Gen (CardanoTx, [TxOut]) +genInitialTransaction GeneratorModel {..} = do + let pkAddr pk = either (error . show) id $ LC.toCardanoAddressInEra testnet $ pubKeyAddress pk Nothing + initialDist = Map.mapKeys pkAddr $ fmap Value.lovelaceToValue gmInitialBalance + let tx@(CardanoEmulatorEraTx (C.Tx (C.TxBody txBodyContent) _)) = createGenesisTransaction initialDist + txOuts = Tx.TxOut <$> C.txOuts txBodyContent + pure (tx, txOuts) + +-- | Generate a valid transaction, using the unspent outputs provided. +-- Fails if the there are no unspent outputs, or if the total value +-- of the unspent outputs is smaller than the minimum fee. +genValidTransaction :: + Mockchain -> + Gen CardanoTx +genValidTransaction = genValidTransaction' generatorModel + +genValidTransactionBody :: + Mockchain -> + Gen (C.TxBodyContent C.BuildTx C.ConwayEra) +genValidTransactionBody = genValidTransactionBody' generatorModel + +-- | Generate a valid transaction, using the unspent outputs provided. +-- Fails if the there are no unspent outputs, or if the total value +-- of the unspent outputs is smaller than the estimated fee. +genValidTransaction' :: + GeneratorModel -> + Mockchain -> + Gen CardanoTx +genValidTransaction' g chain = genValidTransactionBody' g chain >>= makeTx + +genValidTransactionSpending :: + [C.TxIn] -> + C.Value -> + Gen CardanoTx +genValidTransactionSpending = genValidTransactionSpending' generatorModel + +genValidTransactionSpending' :: + GeneratorModel -> + [C.TxIn] -> + C.Value -> + Gen CardanoTx +genValidTransactionSpending' g ins totalVal = + genValidTransactionBodySpending' g ins totalVal >>= makeTx + +makeTx :: + (MonadFail m) => + C.TxBodyContent C.BuildTx C.ConwayEra -> + m CardanoTx +makeTx bodyContent = do + txBody <- + either (fail . ("makeTx: Can't create TxBody: " <>) . show) pure $ + C.createTransactionBody C.shelleyBasedEra bodyContent + pure $ signAll $ CardanoEmulatorEraTx $ C.Tx txBody [] + +-- | Generate a valid transaction, using the unspent outputs provided. +-- Fails if the there are no unspent outputs, or if the total value +-- of the unspent outputs is smaller than the estimated fee. +genValidTransactionBody' :: + GeneratorModel -> + Mockchain -> + Gen (C.TxBodyContent C.BuildTx C.ConwayEra) +genValidTransactionBody' g (Mockchain _ ops _) = do + -- Take a random number of UTXO from the input + nUtxo <- + if Map.null ops + then Gen.discard + else Gen.int (Range.linear 1 (Map.size ops)) + let ins = fst <$> inUTXO + inUTXO = take nUtxo $ Map.toList ops + totalVal = foldMap (txOutValue . snd) inUTXO + genValidTransactionBodySpending' g ins totalVal + +genValidTransactionBodySpending' :: + GeneratorModel -> + [C.TxIn] -> + C.Value -> + Gen (C.TxBodyContent C.BuildTx C.ConwayEra) +genValidTransactionBodySpending' g ins totalVal = do + mintAmount <- toInteger <$> Gen.int (Range.linear 0 maxBound) + mintTokenName <- Gen.genAssetName + let mintValue = guard (mintAmount /= 0) $> someTokenValue mintTokenName mintAmount + fee' = Coin 300_000 + numOut = Set.size (gmPubKeys g) - 1 + totalValAda = C.selectLovelace totalVal + totalValTokens = guard (not $ Value.isZero (Value.noAdaValue totalVal)) $> Value.noAdaValue totalVal + canPayTheFees = fee' < totalValAda + guard canPayTheFees + -- We only split the Ada part of the input value + splitOutVals <- splitVal numOut (totalValAda - fee') + let outVals = case totalValTokens <> mintValue of + Nothing -> Value.lovelaceToValue <$> splitOutVals + Just mv -> do + -- If there is a minted value, we look for a value in the + -- splitted values which can be associated with it. + let outValForMint = + fromMaybe mempty $ + List.find (>= Ledger.minLovelaceTxOutEstimated) $ + List.sort splitOutVals + Value.lovelaceToValue outValForMint + <> mv + : fmap Value.lovelaceToValue (List.delete outValForMint splitOutVals) + pubKeys <- Gen.shuffle $ Set.toList $ gmPubKeys g + let txOutputs = + either (fail . ("Cannot create outputs: " <>) . show) id $ + traverse (\(v, ppk) -> pubKeyTxOut v ppk Nothing) $ + zip outVals pubKeys + let mintWitness = + C.PlutusScriptWitness + C.PlutusScriptV1InConway + C.PlutusScriptV1 + (C.PScript $ C.examplePlutusScriptAlwaysSucceeds C.WitCtxMint) + C.NoScriptDatumForMint + (C.unsafeHashableScriptData $ C.fromPlutusData $ toData Script.unitRedeemer) + LC.zeroExecutionUnits + let txMintValue = + if mintAmount == 0 + then C.TxMintNone + else + C.TxMintValue + C.MaryEraOnwardsConway + $ Map.singleton + alwaysSucceedPolicyId + [(mintTokenName, C.Quantity mintAmount, C.BuildTxWith mintWitness)] + txIns = map (,C.BuildTxWith $ C.KeyWitness C.KeyWitnessForSpending) ins + txInsCollateral <- + maybe + (fail "Cannot gen collateral") + (pure . C.TxInsCollateral C.AlonzoEraOnwardsConway . flip take ins . fromIntegral) + (gmMaxCollateralInputs g) + pure $ + Tx.emptyTxBodyContent + { C.txIns, + C.txInsCollateral, + C.txMintValue, + C.txFee = LC.toCardanoFee fee', + C.txOuts = Tx.getTxOut <$> txOutputs + } + +-- | Create a transaction output locked by a public payment key and optionnaly a public stake key. +pubKeyTxOut :: + C.Value -> PaymentPubKey -> Maybe V1.StakingCredential -> Either LC.ToCardanoError TxOut +pubKeyTxOut v pk sk = do + aie <- LC.toCardanoAddressInEra testnet $ pubKeyAddress pk sk + pure $ Tx.TxOut $ C.TxOut aie (LC.toCardanoTxOutValue v) C.TxOutDatumNone C.ReferenceScriptNone + +-- | Validate a transaction in a mockchain. +validateMockchain :: Mockchain -> CardanoTx -> Maybe Ledger.ValidationErrorInPhase +validateMockchain (Mockchain _ utxo params) tx = result + where + cUtxoIndex = LC.fromPlutusIndex $ C.UTxO $ Tx.toCtxUTxOTxOut <$> utxo + ledgerState = + initialState params + & updateSlot (const 1) + & setUtxo params cUtxoIndex + result = case snd $ validateCardanoTx params ledgerState tx of + FailPhase1 _ err -> Just (Phase1, err) + FailPhase2 _ err _ -> Just (Phase2, err) + _ -> Nothing + +-- | Generate an 'Interval where the lower bound if less or equal than the +-- upper bound. +genInterval :: + (MonadFail m, Ord a) => + m a -> + m (Interval a) +genInterval gen = do + [b, e] <- sort <$> replicateM 2 gen + return $ Interval.interval b e + +-- | Generate a 'SlotRange' where the lower bound if less or equal than the +-- upper bound. +genSlotRange :: (MonadFail m, Hedgehog.MonadGen m) => m SlotRange +genSlotRange = genInterval genSlot + +-- | Generate a 'POSIXTimeRange' where the lower bound if less or equal than the +-- upper bound. +genTimeRange :: (MonadFail m, Hedgehog.MonadGen m) => SlotConfig -> m POSIXTimeRange +genTimeRange sc = genInterval $ genPOSIXTime sc + +-- | Generate a 'Slot' where the lowest slot number is 0. +genSlot :: (Hedgehog.MonadGen m) => m Slot +genSlot = Slot <$> Gen.integral (Range.linear 0 10_000) + +-- | Generate a 'POSIXTime' where the lowest value is 'scSlotZeroTime' given a +-- 'SlotConfig'. +genPOSIXTime :: (Hedgehog.MonadGen m) => SlotConfig -> m POSIXTime +genPOSIXTime sc = do + let beginTime = getPOSIXTime $ TimeSlot.scSlotZeroTime sc + POSIXTime <$> Gen.integral (Range.linear beginTime (beginTime + 10_000_000)) + +-- | Generate a 'SlotConfig' where the slot length goes from 1 to 100000 +-- ms and the time of Slot 0 is the default 'scSlotZeroTime'. +genSlotConfig :: (Hedgehog.MonadGen m) => m SlotConfig +genSlotConfig = do + sl <- Gen.integral (Range.linear 1 1_000_000) + return $ def {TimeSlot.scSlotLength = sl} + +-- | Generate a 'ByteString s' of up to @s@ bytes. +genSizedByteString :: forall m. (MonadGen m) => Int -> m BS.ByteString +genSizedByteString s = + let range = Range.linear 0 s + in Gen.bytes range + +-- Copied from Gen.Cardano.Api.Typed, because it's not exported. +genPolicyId :: Gen C.PolicyId +genPolicyId = + Gen.frequency + -- mostly from a small number of choices, so we get plenty of repetition + [ (9, Gen.element [fromString (x : replicate 55 '0') | x <- ['a' .. 'c']]), + -- and some from the full range of the type + (1, C.PolicyId <$> Gen.genScriptHash) + ] + +-- Copied from Gen.Cardano.Api.Typed, because it's not exported. +genAssetId :: Gen C.AssetId +genAssetId = + Gen.choice + [ C.AssetId <$> genPolicyId <*> Gen.genAssetName, + return C.AdaAssetId + ] + +genSingleton :: Range Integer -> Gen C.Value +genSingleton range = Value.assetIdValue <$> genAssetId <*> Gen.integral range + +genValue' :: Range Integer -> Gen C.Value +genValue' valueRange = do + let -- generate values with no more than 5 elements to avoid the tests + -- taking too long (due to the map-as-list-of-kv-pairs implementation) + maxCurrencies = 5 + + numValues <- Gen.int (Range.linear 0 maxCurrencies) + fold <$> traverse (const $ genSingleton valueRange) [0 .. numValues] + +-- | Generate a 'Value' with a value range of @minBound .. maxBound@. +genValue :: Gen C.Value +genValue = genValue' $ fromIntegral <$> Range.linearBounded @Int + +-- | Generate a 'Value' with a value range of @0 .. maxBound@. +genValueNonNegative :: Gen C.Value +genValueNonNegative = genValue' $ fromIntegral <$> Range.linear @Int 0 maxBound + +-- | Assert that a transaction is valid in a chain. +assertValid :: + (MonadTest m, HasCallStack) => + CardanoTx -> + Mockchain -> + m () +assertValid tx mc = + let res = validateMockchain mc tx + in do + H.annotateShow res + H.assert $ isNothing res + +-- | Split a value into max. n positive-valued parts such that the sum of the +-- parts equals the original value. Each part should contain the required +-- minimum amount of Ada. +-- +-- I noticed how for values of `mx` > 1000 the resulting lists are much smaller than +-- one would expect. I think this may be caused by the way we select the next value +-- for the split. It looks like the available funds get exhausted quite fast, which +-- makes the function return before generating anything close to `mx` values. +splitVal :: (MonadGen m, Integral n) => Int -> n -> m [n] +splitVal _ 0 = pure [] +splitVal mx init' = go 0 0 [] + where + go i c l = + if i >= pred mx || init' - c < 2 * minAda + then pure $ (init' - c) : l + else do + v <- Gen.integral (Range.linear minAda $ init' - c - minAda) + if v + c == init' + then pure $ v : l + else go (succ i) (v + c) (v : l) + minAda = 3_000_000 -- For fee and min Ada for tx outs + +knownXPrvs :: [Crypto.XPrv] +knownXPrvs = unPaymentPrivateKey <$> CW.knownPaymentPrivateKeys + +-- | Seed suitable for testing a seed but not for actual wallets as ScrubbedBytes isn't used to ensure +-- memory isn't inspectable +genSeed :: (MonadGen m) => m BS.ByteString +genSeed = Gen.bytes $ Range.singleton 32 + +genPassphrase :: (MonadGen m) => m Passphrase +genPassphrase = + Passphrase <$> Gen.utf8 (Range.singleton 16) Gen.unicode + +alwaysSucceedPolicy :: Script.MintingPolicy +alwaysSucceedPolicy = + Script.MintingPolicy (LC.fromCardanoPlutusScript $ C.examplePlutusScriptAlwaysSucceeds C.WitCtxMint) + +alwaysSucceedPolicyId :: C.PolicyId +alwaysSucceedPolicyId = + C.scriptPolicyId + (C.PlutusScript C.PlutusScriptV1 $ C.examplePlutusScriptAlwaysSucceeds C.WitCtxMint) + +someTokenValue :: C.AssetName -> Integer -> C.Value +someTokenValue an i = fromList [(C.AssetId alwaysSucceedPolicyId an, C.Quantity i)] + +-- | Catch cardano error and fail wi it +failOnCardanoError :: (MonadFail m) => Either LC.ToCardanoError a -> m a +failOnCardanoError = either (fail . show) pure diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/API.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/API.hs new file mode 100644 index 000000000..99eb7523f --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/API.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | If you want to run the node emulator without using the `Contract` monad, this module provides a simple MTL-based interface. +module Cardano.Node.Emulator.Internal.API + ( -- * Types + EmulatorState (EmulatorState), + esChainState, + esAddressMap, + esDatumMap, + EmulatorError (..), + EmulatorLogs, + EmulatorMsg (..), + L.LogMessage (..), + MonadEmulator, + EmulatorT, + EmulatorM, + + -- * Running Eff chain effects in MTL + handleChain, + processBlock, + modifySlot, + ) +where + +import Cardano.Node.Emulator.Internal.Node qualified as E +import Cardano.Node.Emulator.LogMessages (EmulatorMsg (ChainEvent, GenericMsg)) +import Control.Exception (Exception) +import Control.Lens (makeLenses, (&)) +import Control.Monad (void) +import Control.Monad.Error.Class (MonadError) +import Control.Monad.Except (ExceptT) +import Control.Monad.Freer (Eff, Member, interpret, run, type (~>)) +import Control.Monad.Freer.Extras (raiseEnd) +import Control.Monad.Freer.Extras.Log qualified as L +import Control.Monad.Freer.State (State, modify, runState) +import Control.Monad.Freer.Writer qualified as F (Writer, runWriter, tell) +import Control.Monad.Identity (Identity) +import Control.Monad.RWS.Class (MonadRWS, ask, get, put, tell) +import Control.Monad.RWS.Strict (RWST) +import Data.Map (Map) +import Data.Sequence (Seq) +import Ledger + ( Block, + Datum, + DatumHash, + Slot, + ToCardanoError, + ValidationErrorInPhase, + eitherTx, + getCardanoTxData, + ) +import Ledger.AddressMap qualified as AM + +data EmulatorState = EmulatorState + { _esChainState :: !E.ChainState, + _esAddressMap :: !AM.AddressMap, + _esDatumMap :: !(Map DatumHash Datum) + } + deriving (Show) + +makeLenses 'EmulatorState + +data EmulatorError + = ValidationError !ValidationErrorInPhase + | ToCardanoError !ToCardanoError + | CustomError !String + deriving (Show) + +instance Exception EmulatorError + +type EmulatorLogs = Seq (L.LogMessage EmulatorMsg) + +type MonadEmulator m = (MonadRWS E.Params EmulatorLogs EmulatorState m, MonadError EmulatorError m) + +type EmulatorT m = ExceptT EmulatorError (RWST E.Params EmulatorLogs EmulatorState m) + +type EmulatorM = EmulatorT Identity + +handleChain :: (MonadEmulator m) => Eff [E.ChainControlEffect, E.ChainEffect] a -> m a +handleChain eff = do + params <- ask + EmulatorState chainState am dm <- get + let ((((a, dm'), am'), newChainState), lg) = + raiseEnd eff + & interpret (E.handleControlChain params) + & interpret (E.handleChain params) + & interpret handleChainLogs + & runState dm + & runState am + & runState chainState + & F.runWriter + & run + tell lg + put $ EmulatorState newChainState am' dm' + pure a + where + handleChainLogs :: + ( Member (State AM.AddressMap) effs, + Member (State (Map DatumHash Datum)) effs, + Member (F.Writer EmulatorLogs) effs + ) => + L.LogMsg E.ChainEvent ~> Eff effs + handleChainLogs (L.LMessage msg@(L.LogMessage _ e)) = do + F.tell @EmulatorLogs (pure $ ChainEvent <$> msg) + E.chainEventOnChainTx e + & maybe + (pure ()) + ( \tx -> do + void $ modify $ AM.updateAllAddresses tx + void $ modify $ ((<>) . eitherTx getCardanoTxData getCardanoTxData) tx + ) + +processBlock :: (MonadEmulator m) => m Block +processBlock = handleChain E.processBlock + +modifySlot :: (MonadEmulator m) => (Slot -> Slot) -> m Slot +modifySlot f = handleChain $ E.modifySlot f diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node.hs new file mode 100644 index 000000000..09034e93d --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +module Cardano.Node.Emulator.Internal.Node + ( module Export, + ) +where + +import Cardano.Node.Emulator.Internal.Node.Chain as Export +import Cardano.Node.Emulator.Internal.Node.Params as Export +import Cardano.Node.Emulator.Internal.Node.TimeSlot as Export +import Cardano.Node.Emulator.Internal.Node.Validation as Export diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Chain.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Chain.hs new file mode 100644 index 000000000..c2f3f1bed --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Chain.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Cardano.Node.Emulator.Internal.Node.Chain where + +import Cardano.Node.Emulator.Internal.Node.Params (Params) +import Cardano.Node.Emulator.Internal.Node.Validation qualified as Validation +import Control.Lens (makeLenses, makePrisms, over, view, (%~), (&), (.~)) +import Control.Monad.Freer (Eff, Member, Members, send, type (~>)) +import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo, logWarn) +import Control.Monad.Freer.State (State, gets, modify) +import Control.Monad.State qualified as S +import Data.Aeson (FromJSON, ToJSON) +import Data.Foldable (traverse_) +import Data.List ((\\)) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Traversable (for) +import GHC.Generics (Generic) +import Ledger + ( Block, + Blockchain, + CardanoTx, + OnChainTx, + Slot, + getCardanoTxId, + unOnChain, + ) +import Ledger.Index qualified as Index +import Prettyprinter (Pretty (pretty), vsep, (<+>)) + +-- | Events produced by the blockchain emulator. +data ChainEvent + = -- | A transaction has been validated and added to the blockchain. + TxnValidation !Index.ValidationResult + | SlotAdd !Slot + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Pretty ChainEvent where + pretty = \case + TxnValidation res -> + vsep + ["TxnValidation" <+> pretty (getCardanoTxId $ Index.cardanoTxFromValidationResult res), pretty res] + SlotAdd sl -> "SlotAdd" <+> pretty sl + +chainEventOnChainTx :: ChainEvent -> Maybe OnChainTx +chainEventOnChainTx (TxnValidation result) = Index.toOnChain result +chainEventOnChainTx _ = Nothing + +-- | A pool of transactions which have yet to be validated. +type TxPool = [CardanoTx] + +data ChainState = ChainState + { -- | The current chain, with the newest transactions first in the list. + _chainNewestFirst :: !Blockchain, + -- | The pool of pending transactions. + _txPool :: !TxPool, + -- | The UTxO index, used for validation. + _index :: !Index.UtxoIndex, + -- | The internal state of the ledger. + _ledgerState :: Validation.EmulatedLedgerState + } + deriving (Show, Generic) + +makeLenses ''ChainState + +emptyChainState :: Params -> ChainState +emptyChainState params = ChainState [] [] mempty (Validation.initialState params) + +fromBlockchain :: Params -> Blockchain -> ChainState +fromBlockchain params bc = + emptyChainState params + & chainNewestFirst .~ bc + & index .~ Index.initialise bc + +data ChainControlEffect r where + ProcessBlock :: ChainControlEffect Block + ModifySlot :: (Slot -> Slot) -> ChainControlEffect Slot + +data ChainEffect r where + QueueTx :: CardanoTx -> ChainEffect () + GetCurrentSlot :: ChainEffect Slot + GetParams :: ChainEffect Params + +-- | Make a new block +processBlock :: (Member ChainControlEffect effs) => Eff effs Block +processBlock = send ProcessBlock + +-- | Adjust the current slot number, returning the new slot. +modifySlot :: (Member ChainControlEffect effs) => (Slot -> Slot) -> Eff effs Slot +modifySlot = send . ModifySlot + +queueTx :: (Member ChainEffect effs) => CardanoTx -> Eff effs () +queueTx tx = send (QueueTx tx) + +getParams :: (Member ChainEffect effs) => Eff effs Params +getParams = send GetParams + +getCurrentSlot :: (Member ChainEffect effs) => Eff effs Slot +getCurrentSlot = send GetCurrentSlot + +type ChainEffs = '[State ChainState, LogMsg ChainEvent] + +handleControlChain :: (Members ChainEffs effs) => Params -> ChainControlEffect ~> Eff effs +handleControlChain params = \case + ProcessBlock -> do + pool <- gets $ view txPool + idx <- gets $ view index + ls <- gets $ view ledgerState + + let ValidatedBlock block events idx' ls' = + validateBlock params idx ls pool + + modify $ txPool .~ [] + modify $ index .~ idx' + modify $ ledgerState .~ ls' + modify $ addBlock block + + traverse_ logEvent events + pure block + ModifySlot f -> do + _ <- + modify @ChainState + ( over + ledgerState + (Validation.updateSlot (\(Validation.SlotNo s) -> fromIntegral (f (fromIntegral s)))) + ) + gets (Validation.getSlot . view ledgerState) + +logEvent :: (Member (LogMsg ChainEvent) effs) => ChainEvent -> Eff effs () +logEvent e = case e of + SlotAdd {} -> logDebug e + TxnValidation Index.FailPhase1 {} -> logWarn e + TxnValidation Index.FailPhase2 {} -> logWarn e + TxnValidation Index.Success {} -> logInfo e + +handleChain :: (Members ChainEffs effs) => Params -> ChainEffect ~> Eff effs +handleChain params = \case + QueueTx tx -> modify (addTxToPool tx) + GetCurrentSlot -> gets (Validation.getSlot . view ledgerState) + GetParams -> pure params + +-- | The result of validating a block. +data ValidatedBlock = ValidatedBlock + { -- | The transactions that have been validated in this block. + vlbValid :: !Block, + -- | Transaction validation events for the transactions in this block. + vlbEvents :: ![ChainEvent], + -- | The updated UTxO index after processing the block + vlbIndex :: !Index.UtxoIndex, + vlbLedgerState :: !Validation.EmulatedLedgerState + } + +data ValidationCtx = ValidationCtx + { vctxIndex :: !Index.UtxoIndex, + vctxParams :: !Params, + vctxLedgerState :: Validation.EmulatedLedgerState + } + +-- | Validate a block given the current slot and UTxO index, returning the valid +-- transactions, success/failure events and the updated UTxO set. +validateBlock :: + Params -> Index.UtxoIndex -> Validation.EmulatedLedgerState -> TxPool -> ValidatedBlock +validateBlock params idx ls txns = + let -- Validate transactions, updating the UTXO index each time + (results, ValidationCtx idx' _ ls') = + flip S.runState (ValidationCtx idx params ls) $ for txns validateEm + + -- The new block contains all transaction that were validated + -- successfully + block = mapMaybe Index.toOnChain results + + -- Also return an `EmulatorEvent` for each transaction that was + -- processed + nextSlot = Validation.getSlot ls + 1 + events = (TxnValidation <$> results) ++ [SlotAdd nextSlot] + in ValidatedBlock block events idx' ls' + +-- | Validate a transaction in the current emulator state. +validateEm :: + (S.MonadState ValidationCtx m) => + CardanoTx -> + m Index.ValidationResult +validateEm txn = do + ctx@(ValidationCtx idx params ls) <- S.get + let (ls', res) = Validation.validateCardanoTx params ls txn + idx' = case res of + Index.FailPhase1 {} -> idx + Index.FailPhase2 {} -> Index.insertCollateral txn idx + Index.Success {} -> Index.insert txn idx + _ <- S.put ctx {vctxIndex = idx', vctxLedgerState = fromMaybe ls ls'} + pure res + +-- | Adds a block to ChainState, without validation. +addBlock :: Block -> ChainState -> ChainState +addBlock blk st = + st + & chainNewestFirst %~ (blk :) + -- The block update may contain txs that are not in this client's + -- `txPool` which will get ignored + & txPool %~ (\\ map unOnChain blk) + +addTxToPool :: CardanoTx -> ChainState -> ChainState +addTxToPool tx = over txPool (tx :) + +makePrisms ''ChainEvent diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs new file mode 100644 index 000000000..cc7bd1e71 --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The set of parameters, like protocol parameters and slot configuration. +module Cardano.Node.Emulator.Internal.Node.Params + ( Params (..), + paramsFromConfig, + C.mkLatestTransitionConfig, + slotConfigL, + networkIdL, + emulatorPParamsL, + emulatorPParams, + ledgerProtocolParameters, + increaseTransactionLimits, + increaseTransactionLimits', + emulatorEpochSize, + emulatorShelleyGenesisDefaults, + emulatorAlonzoGenesisDefaults, + emulatorConwayGenesisDefaults, + keptBlocks, + + -- * cardano-ledger specific types and conversion functions + EmulatorEra, + PParams, + TransitionConfig, + slotLength, + testnet, + emulatorGlobals, + emulatorEraHistory, + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.NetworkId qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Ledger.Alonzo.Genesis qualified as C +import Cardano.Ledger.Alonzo.PParams qualified as C +import Cardano.Ledger.Api.PParams qualified as C +import Cardano.Ledger.Api.Transition qualified as C +import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), boundRational) +import Cardano.Ledger.Binary.Version (Version, natVersion) +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Plutus.ExUnits (ExUnits (ExUnits), Prices (Prices)) +import Cardano.Ledger.Shelley.API (Coin (Coin), Globals, mkShelleyGlobals) +import Cardano.Ledger.Shelley.API qualified as C.Ledger +import Cardano.Ledger.Slot (EpochSize (EpochSize)) +import Cardano.Node.Emulator.Internal.Node.TimeSlot + ( SlotConfig (SlotConfig, scSlotLength, scSlotZeroTime), + beginningOfTime, + nominalDiffTimeToPOSIXTime, + posixTimeToNominalDiffTime, + posixTimeToUTCTime, + utcTimeToPOSIXTime, + ) +import Cardano.Slotting.EpochInfo (fixedEpochInfo) +import Cardano.Slotting.Time (SlotLength, mkSlotLength) +import Control.Lens (makeLensesFor, over, (%~), (&), (.~), (^.)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) +import Data.Aeson qualified as JSON +import Data.Aeson.Types (prependFailure, typeMismatch) +import Data.Default (Default (def)) +import Data.Maybe (fromJust) +import Data.Ratio ((%)) +import Data.SOP (K (K)) +import Data.SOP.Counting qualified as Ouroboros +import Data.SOP.NonEmpty qualified as Ouroboros +import Data.SOP.Strict (NP (Nil, (:*))) +import GHC.Generics (Generic) +import GHC.Natural (Natural) +import GHC.Word (Word32) +import Ledger.Test (testNetworkMagic, testnet) +import Ouroboros.Consensus.Block (GenesisWindow (GenesisWindow)) +import Ouroboros.Consensus.HardFork.History qualified as Ouroboros +import PlutusLedgerApi.V1 (POSIXTime (POSIXTime, getPOSIXTime)) +import Prettyprinter (Pretty (pretty), viaShow, vsep, (<+>)) + +-- | The default era for the emulator +type EmulatorEra = ConwayEra StandardCrypto + +type PParams = C.PParams EmulatorEra + +type TransitionConfig = C.TransitionConfig EmulatorEra + +data Params = Params + { pSlotConfig :: !SlotConfig, + pEmulatorPParams :: !PParams, + pNetworkId :: !C.NetworkId, + pEpochSize :: !EpochSize, + pConfig :: !TransitionConfig + } + deriving (Eq, Show, Generic) + +instance ToJSON C.NetworkId where + toJSON C.Mainnet = JSON.String "Mainnet" + toJSON (C.Testnet (C.NetworkMagic n)) = JSON.Number $ fromIntegral n + +instance FromJSON C.NetworkId where + parseJSON (JSON.String "Mainnet") = pure C.Mainnet + parseJSON (JSON.Number n) = pure $ C.Testnet $ C.NetworkMagic $ truncate n + parseJSON v = + prependFailure "parsing NetworkId failed, " (typeMismatch "'Mainnet' or Number" v) + +deriving newtype instance ToJSON C.NetworkMagic + +deriving newtype instance FromJSON C.NetworkMagic + +makeLensesFor + [ ("pSlotConfig", "slotConfigL"), + ("pEmulatorPParams", "emulatorPParamsL"), + ("pNetworkId", "networkIdL") + ] + ''Params + +instance Default Params where + def = paramsFromConfig defaultConfig + +instance Pretty Params where + pretty Params {..} = + vsep + [ "Slot config:" <+> pretty pSlotConfig, + "Network ID:" <+> viaShow pNetworkId, + "Protocol Parameters:" <+> viaShow pEmulatorPParams + ] + +-- | Convert `Params` to cardano-ledger `PParams` +emulatorPParams :: Params -> PParams +emulatorPParams = pEmulatorPParams + +ledgerProtocolParameters :: Params -> C.LedgerProtocolParameters C.ConwayEra +ledgerProtocolParameters = C.LedgerProtocolParameters . emulatorPParams + +-- | Set higher limits on transaction size and execution units. +-- This can be used to work around @MaxTxSizeUTxO@ and @ExUnitsTooBigUTxO@ errors. +-- Note that if you need this your Plutus script will probably not validate on Mainnet. +increaseTransactionLimits :: Params -> Params +increaseTransactionLimits = increaseTransactionLimits' 2 10 10 + +increaseTransactionLimits' :: Word32 -> Natural -> Natural -> Params -> Params +increaseTransactionLimits' size steps mem = + over emulatorPParamsL $ + (C.ppMaxTxSizeL %~ (size *)) . (C.ppMaxTxExUnitsL %~ f) + where + f :: ExUnits -> ExUnits + f (ExUnits executionSteps executionMemory) = + ExUnits (steps * executionSteps) (mem * executionMemory) + +emulatorProtocolMajorVersion :: Version +emulatorProtocolMajorVersion = natVersion @9 + +defaultConfig :: TransitionConfig +defaultConfig = + C.mkLatestTransitionConfig + emulatorShelleyGenesisDefaults + emulatorAlonzoGenesisDefaults + emulatorConwayGenesisDefaults + +emulatorShelleyGenesisDefaults :: C.ShelleyGenesis StandardCrypto +emulatorShelleyGenesisDefaults = + C.shelleyGenesisDefaults + { C.sgNetworkMagic = case testNetworkMagic of C.NetworkMagic nm -> nm, + C.sgSystemStart = posixTimeToUTCTime $ POSIXTime beginningOfTime, + C.sgProtocolParams = + C.sgProtocolParams C.shelleyGenesisDefaults + & C.ppProtocolVersionL .~ ProtVer emulatorProtocolMajorVersion 0 + & C.ppMinFeeBL .~ Coin 155_381 + & C.ppMinFeeAL .~ Coin 44 + & C.ppKeyDepositL .~ Coin 2_000_000 + } + +instance MonadFail (Either String) where + fail = Left + +emulatorAlonzoGenesisDefaults :: C.AlonzoGenesis +emulatorAlonzoGenesisDefaults = + (C.alonzoGenesisDefaults C.ConwayEra) + { C.agPrices = + Prices (fromJust $ boundRational (577 % 10_000)) (fromJust $ boundRational (721 % 10_000_000)), + C.agMaxTxExUnits = ExUnits 14_000_000 10_000_000_000 + } + +emulatorConwayGenesisDefaults :: C.ConwayGenesis StandardCrypto +emulatorConwayGenesisDefaults = C.conwayGenesisDefaults + +paramsFromConfig :: TransitionConfig -> Params +paramsFromConfig tc = + Params + { pSlotConfig = + SlotConfig + { scSlotZeroTime = utcTimeToPOSIXTime $ C.sgSystemStart sg, + scSlotLength = + getPOSIXTime $ nominalDiffTimeToPOSIXTime $ C.Ledger.fromNominalDiffTimeMicro $ C.sgSlotLength sg + }, + pEmulatorPParams = tc ^. C.tcInitialPParamsG, + pNetworkId = C.fromShelleyNetwork (C.sgNetworkId sg) (C.NetworkMagic $ C.sgNetworkMagic sg), + pEpochSize = C.sgEpochLength sg, + pConfig = tc + } + where + sg = tc ^. C.tcShelleyGenesisL + +-- | Calculate the cardano-ledger `SlotLength` +slotLength :: Params -> SlotLength +slotLength Params {pSlotConfig} = mkSlotLength $ posixTimeToNominalDiffTime $ POSIXTime $ scSlotLength pSlotConfig + +keptBlocks :: Params -> Integer +keptBlocks Params {pConfig} = fromIntegral $ C.sgSecurityParam (pConfig ^. C.tcShelleyGenesisL) + +-- | A sensible default 'EpochSize' value for the emulator +emulatorEpochSize :: EpochSize +emulatorEpochSize = EpochSize 432_000 + +-- | A sensible default 'Globals' value for the emulator +emulatorGlobals :: Params -> Globals +emulatorGlobals params@Params {pEpochSize, pConfig} = + mkShelleyGlobals + (pConfig ^. C.tcShelleyGenesisL) + (fixedEpochInfo pEpochSize (slotLength params)) + +emulatorGenesisWindow :: GenesisWindow +emulatorGenesisWindow = GenesisWindow window + where + -- A good default value for eras that never fork is + -- 3k/f, with k = 2160 and f = 20 (given by the Genesis team). + window = (3 * 2160) `div` 20 + +-- | A sensible default 'EraHistory' value for the emulator +emulatorEraHistory :: Params -> C.EraHistory +emulatorEraHistory params = C.EraHistory (Ouroboros.mkInterpreter $ Ouroboros.summaryWithExactly list) + where + one = + Ouroboros.nonEmptyHead $ + Ouroboros.getSummary $ + Ouroboros.neverForksSummary (pEpochSize params) (slotLength params) emulatorGenesisWindow + list = Ouroboros.Exactly $ K one :* K one :* K one :* K one :* K one :* K one :* K one :* Nil diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs new file mode 100644 index 000000000..aee5efff7 --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Node.Emulator.Internal.Node.TimeSlot + ( SlotConfig (..), + SlotConversionError (..), + slotRangeToPOSIXTimeRange, + slotToPOSIXTimeRange, + slotToBeginPOSIXTime, + slotToEndPOSIXTime, + posixTimeRangeToContainedSlotRange, + posixTimeToEnclosingSlot, + currentSlot, + utcTimeToPOSIXTime, + posixTimeToUTCTime, + nominalDiffTimeToPOSIXTime, + posixTimeToNominalDiffTime, + beginningOfTime, + ) +where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Default (Default (def)) +import Data.Time.Clock qualified as Time +import Data.Time.Clock.POSIX qualified as Time +import GHC.Generics (Generic) +import Ledger.Orphans () +import Ledger.Slot (Slot (Slot), SlotRange) +import PlutusLedgerApi.V1.Interval + ( Extended (Finite), + Interval (Interval), + LowerBound (LowerBound), + UpperBound (UpperBound), + interval, + member, + ) +import PlutusLedgerApi.V1.Time (POSIXTime (POSIXTime, getPOSIXTime), POSIXTimeRange) +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude (Integer, divide, fmap, ($), (*), (+), (-), (.)) +import Prettyprinter (Pretty (pretty), (<+>)) +import Prelude (Eq, IO, Show, (<$>)) +import Prelude qualified as Haskell + +-- | Datatype to configure the length (ms) of one slot and the beginning of the +-- first slot. +data SlotConfig = SlotConfig + { -- | Length (number of milliseconds) of one slot + scSlotLength :: !Integer, + -- | Beginning of slot 0 (in milliseconds) + scSlotZeroTime :: !POSIXTime + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +makeLift ''SlotConfig + +instance Default SlotConfig where + {-# INLINEABLE def #-} + def = SlotConfig {scSlotLength = 1000, scSlotZeroTime = POSIXTime beginningOfTime} + +instance Pretty SlotConfig where + pretty SlotConfig {scSlotLength, scSlotZeroTime} = + "Slot 0 starts at" + <+> pretty scSlotZeroTime + <+> "and one slot has length of" + <+> pretty scSlotLength + <+> "ms" + +data SlotConversionError = SlotOutOfRange + { requestedSlot :: !Slot, + horizon :: !(Slot, POSIXTime) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Pretty SlotConversionError where + pretty SlotOutOfRange {requestedSlot, horizon} = + "Slot out of range:" + <+> pretty requestedSlot + <+> "Horizon:" + <+> pretty horizon + +{-# INLINEABLE beginningOfTime #-} + +-- | 'beginningOfTime' corresponds to the Shelley launch date +-- (2020-07-29T21:44:51Z) which is 1596059091000 in POSIX time +-- (number of milliseconds since 1970-01-01T00:00:00Z). +beginningOfTime :: Integer +beginningOfTime = 1596059091000 + +{-# INLINEABLE slotRangeToPOSIXTimeRange #-} + +-- | Convert a 'SlotRange' to a 'POSIXTimeRange' given a 'SlotConfig'. The +-- resulting 'POSIXTimeRange' refers to the starting time of the lower bound of +-- the 'SlotRange' and the ending time of the upper bound of the 'SlotRange'. +slotRangeToPOSIXTimeRange :: SlotConfig -> SlotRange -> POSIXTimeRange +slotRangeToPOSIXTimeRange sc (Interval (LowerBound start startIncl) (UpperBound end endIncl)) = + let lbound = fmap (if startIncl then slotToBeginPOSIXTime sc else slotToEndPOSIXTime sc) start + ubound = fmap (if endIncl then slotToEndPOSIXTime sc else slotToBeginPOSIXTime sc) end + in Interval (LowerBound lbound startIncl) (UpperBound ubound endIncl) + +{-# INLINEABLE slotToPOSIXTimeRange #-} + +-- | Convert a 'Slot' to a 'POSIXTimeRange' given a 'SlotConfig'. Each 'Slot' +-- can be represented by an interval of time. +slotToPOSIXTimeRange :: SlotConfig -> Slot -> POSIXTimeRange +slotToPOSIXTimeRange sc slot = + interval (slotToBeginPOSIXTime sc slot) (slotToEndPOSIXTime sc slot) + +{-# INLINEABLE slotToBeginPOSIXTime #-} + +-- | Get the starting 'POSIXTime' of a 'Slot' given a 'SlotConfig'. +slotToBeginPOSIXTime :: SlotConfig -> Slot -> POSIXTime +slotToBeginPOSIXTime SlotConfig {scSlotLength, scSlotZeroTime} (Slot n) = + let msAfterBegin = n * scSlotLength + in POSIXTime $ getPOSIXTime scSlotZeroTime + msAfterBegin + +{-# INLINEABLE slotToEndPOSIXTime #-} + +-- | Get the ending 'POSIXTime' of a 'Slot' given a 'SlotConfig'. +slotToEndPOSIXTime :: SlotConfig -> Slot -> POSIXTime +slotToEndPOSIXTime sc@SlotConfig {scSlotLength} slot = + slotToBeginPOSIXTime sc slot + POSIXTime (scSlotLength - 1) + +{-# INLINEABLE posixTimeRangeToContainedSlotRange #-} + +-- | Convert a 'POSIXTimeRange' to 'SlotRange' given a 'SlotConfig'. This gives +-- the biggest slot range that is entirely contained by the given time range. +posixTimeRangeToContainedSlotRange :: SlotConfig -> POSIXTimeRange -> SlotRange +posixTimeRangeToContainedSlotRange sc ptr = case fmap (posixTimeToEnclosingSlot sc) ptr of + Interval (LowerBound start startIncl) (UpperBound end endIncl) -> + Interval + ( LowerBound start (case start of Finite s -> slotToBeginPOSIXTime sc s `member` ptr; _ -> startIncl) + ) + (UpperBound end (case end of Finite e -> slotToEndPOSIXTime sc e `member` ptr; _ -> endIncl)) + +{-# INLINEABLE posixTimeToEnclosingSlot #-} + +-- | Convert a 'POSIXTime' to 'Slot' given a 'SlotConfig'. +posixTimeToEnclosingSlot :: SlotConfig -> POSIXTime -> Slot +posixTimeToEnclosingSlot SlotConfig {scSlotLength, scSlotZeroTime} (POSIXTime t) = + let timePassed = t - getPOSIXTime scSlotZeroTime + slotsPassed = divide timePassed scSlotLength + in Slot slotsPassed + +-- | Get the current slot number +currentSlot :: SlotConfig -> IO Slot +currentSlot sc = timeToSlot <$> Time.getPOSIXTime + where + timeToSlot = + posixTimeToEnclosingSlot sc + . nominalDiffTimeToPOSIXTime + +utcTimeToPOSIXTime :: Time.UTCTime -> POSIXTime +utcTimeToPOSIXTime = nominalDiffTimeToPOSIXTime . Time.utcTimeToPOSIXSeconds + +posixTimeToUTCTime :: POSIXTime -> Time.UTCTime +posixTimeToUTCTime = Time.posixSecondsToUTCTime . posixTimeToNominalDiffTime + +nominalDiffTimeToPOSIXTime :: Time.NominalDiffTime -> POSIXTime +nominalDiffTimeToPOSIXTime = + POSIXTime + . Haskell.truncate + . (Haskell.* 1000) -- Convert to ms + . Time.nominalDiffTimeToSeconds + +posixTimeToNominalDiffTime :: POSIXTime -> Time.NominalDiffTime +posixTimeToNominalDiffTime = + Time.secondsToNominalDiffTime + . (Haskell./ 1000) + . Haskell.fromInteger + . getPOSIXTime diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs new file mode 100644 index 000000000..9a0584466 --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Transaction validation using 'cardano-ledger-specs' +module Cardano.Node.Emulator.Internal.Node.Validation + ( EmulatedLedgerState (..), + Coin (..), + SlotNo (..), + EmulatorEra, + CardanoLedgerError, + initialState, + hasValidationErrors, + createAndValidateTransactionBody, + validateCardanoTx, + getTxExUnitsWithLogs, + unsafeMakeValid, + validateAndApplyTx, + + -- * Modifying the state + updateSlot, + nextSlot, + getSlot, + UTxO (..), + setUtxo, + + -- * Lenses + ledgerEnv, + memPoolState, + + -- * Etc. + emulatorGlobals, + ) +where + +import Cardano.Api.Error qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Ledger.Alonzo.Plutus.Evaluate + ( collectPlutusScriptsWithContext, + evalPlutusScripts, + ) +import Cardano.Ledger.Alonzo.Rules + ( AlonzoUtxoPredFailure (UtxosFailure), + AlonzoUtxosPredFailure (CollectErrors), + ) +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (AlonzoTx), IsValid (IsValid)) +import Cardano.Ledger.Api.Transition (createInitialState) +import Cardano.Ledger.Api.Tx + ( TransactionScriptFailure (ValidationFailure), + evalTxExUnitsWithLogs, + ) +import Cardano.Ledger.BaseTypes (Globals (systemStart), epochInfo) +import Cardano.Ledger.Conway.Rules (ConwayLedgerPredFailure (ConwayUtxowFailure)) +import Cardano.Ledger.Core qualified as Core +import Cardano.Ledger.Plutus.Evaluate (ScriptResult (Fails, Passes)) +import Cardano.Ledger.Shelley.API + ( ApplyTxError (ApplyTxError), + Coin (Coin), + LedgerEnv (LedgerEnv, ledgerSlotNo), + LedgerState (lsUTxOState), + MempoolEnv, + UTxO (UTxO), + Validated, + unsafeMakeValidated, + ) +import Cardano.Ledger.Shelley.API qualified as C.Ledger +import Cardano.Ledger.Shelley.LedgerState (esLState, nesEs, smartUTxOState, utxosUtxo) +import Cardano.Node.Emulator.Internal.Node.Params + ( EmulatorEra, + Params (pConfig), + emulatorGlobals, + emulatorPParams, + ledgerProtocolParameters, + ) +import Cardano.Slotting.Slot (SlotNo (SlotNo)) +import Control.Lens (makeLenses, over, view, (&), (.~)) +import Control.Monad.Except (MonadError (throwError)) +import Data.Bifunctor (Bifunctor (first), bimap) +import Data.Default (def) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map qualified as Map +import Data.Text qualified as Text +import Ledger.Blockchain (OnChainTx (OnChainTx)) +import Ledger.Index (genesisTxIn, getCollateral) +import Ledger.Index.Internal qualified as P +import Ledger.Tx (CardanoTx (CardanoEmulatorEraTx)) +import Ledger.Tx.CardanoAPI qualified as P +import PlutusLedgerApi.V1 qualified as V1 hiding (TxOut (..)) +import PlutusLedgerApi.V1.Scripts qualified as P + +type CardanoLedgerError = Either P.ValidationErrorInPhase P.ToCardanoError + +{- Note [Emulated ledger] + +In the real cardano node, there two types of validation: Transaction validation +(performed when a transaction is first added to the mempool) and block +validation (performed when a block is created by the local node or received +from a peer). + +Transaction validation runs the Plutus scripts, checks cryptographic +signatures, balances, existence of transaction inputs and so forth. This is +where the ledger state is updated. Block validation performs other checks +related to the consensus algorithm. + +Networking and consensus issues are not part of the emulator's scope. We only +care about transaction validation here, so we don't have to worry about block +validation. + +The decision to leave out block validation and consensus-related concerns has +the following implications: + +1. We can represent blocks as simple lists-of-transactions +2. We can modify time (the slot number) and ledger parameters as we wish, + without having to post transactions that modify them. + +There are also some limitations of the emulator's functionality that could be +addressed by extending the emulator, without having to bring in the full block +validating machinery. + +\* We cannot represent different eras - everything is 'ConwayEra'. +\* There is no handling of epoch boundaries, rewards, etc. +\* The block size is unlimited - we simply take all transactions from the + mempool when we make a block. There is however a limit on the size of + individual transactions. +\* We use the standard ledger cryptography everywhere ('StandardCrypto'). + This could be replaced by "NoCrypto" for faster validation. + +-} + +-- | State of the ledger with configuration, mempool, and the blockchain. +data EmulatedLedgerState = EmulatedLedgerState + { _ledgerEnv :: !(MempoolEnv EmulatorEra), + _memPoolState :: !(LedgerState EmulatorEra) + } + deriving (Show) + +makeLenses ''EmulatedLedgerState + +-- | Increase the slot number by one +nextSlot :: EmulatedLedgerState -> EmulatedLedgerState +nextSlot = over ledgerEnv f + where + f l@LedgerEnv {ledgerSlotNo = oldSlot} = l {ledgerSlotNo = succ oldSlot} + +-- | Set the slot number +updateSlot :: (SlotNo -> SlotNo) -> EmulatedLedgerState -> EmulatedLedgerState +updateSlot f = over ledgerEnv (\l -> l {ledgerSlotNo = f (ledgerSlotNo l)}) + +-- | Get the slot number +getSlot :: (Num a) => EmulatedLedgerState -> a +getSlot (EmulatedLedgerState LedgerEnv {ledgerSlotNo = SlotNo s} _) = fromIntegral s + +-- | Set the utxo +setUtxo :: Params -> UTxO EmulatorEra -> EmulatedLedgerState -> EmulatedLedgerState +setUtxo params utxo els@EmulatedLedgerState {_memPoolState} = els {_memPoolState = newPoolState} + where + newPoolState = + _memPoolState + { lsUTxOState = smartUTxOState (emulatorPParams params) utxo (Coin 0) (Coin 0) def (Coin 0) + } + +-- | Get the utxo +getUtxo :: EmulatedLedgerState -> UTxO EmulatorEra +getUtxo = utxosUtxo . lsUTxOState . view memPoolState + +-- | Initial ledger state for a distribution +initialState :: Params -> EmulatedLedgerState +initialState params = + EmulatedLedgerState + { _ledgerEnv = + C.Ledger.LedgerEnv + { C.Ledger.ledgerSlotNo = 0, + C.Ledger.ledgerIx = minBound, + C.Ledger.ledgerPp = emulatorPParams params, + C.Ledger.ledgerAccount = C.Ledger.AccountState (Coin 0) (Coin 0), + C.Ledger.ledgerMempool = True -- TODO, what does it mean? + }, + _memPoolState = esLState (nesEs (createInitialState (pConfig params))) + } + +applyTx :: + Params -> + EmulatedLedgerState -> + Core.Tx EmulatorEra -> + Either (ApplyTxError EmulatorEra) (EmulatedLedgerState, Validated (Core.Tx EmulatorEra)) +applyTx params oldState@EmulatedLedgerState {_ledgerEnv, _memPoolState} tx = do + (newMempool, vtx) <- C.Ledger.applyTx (emulatorGlobals params) _ledgerEnv _memPoolState tx + return (oldState & memPoolState .~ newMempool, vtx) + +hasValidationErrors :: + Params -> + EmulatedLedgerState -> + C.Tx C.ConwayEra -> + (Maybe EmulatedLedgerState, P.ValidationResult) +hasValidationErrors params ls tx = + case res of + Left err -> (Nothing, P.FailPhase1 (CardanoEmulatorEraTx tx) err) + Right (ls', vtx) -> case getTxExUnitsWithLogs params utxo tx of + Left (P.Phase1, err) -> (Just ls', P.FailPhase1 (CardanoEmulatorEraTx tx) err) + Left (P.Phase2, err) -> + (Just ls', P.FailPhase2 vtx err $ getCollateral (P.toPlutusIndex utxo) (CardanoEmulatorEraTx tx)) + Right report -> (Just ls', P.Success vtx report) + where + utxo = getUtxo ls + res = + bimap + (P.CardanoLedgerValidationError . Text.pack . show) + (fmap OnChainTx) + (validateAndApplyTx params ls tx) + +validateAndApplyTx :: + Params -> + EmulatedLedgerState -> + C.Tx C.ConwayEra -> + Either (ApplyTxError EmulatorEra) (EmulatedLedgerState, Validated (Core.Tx EmulatorEra)) +validateAndApplyTx params ledgerState (C.ShelleyTx _ tx) = res + where + memPool = _memPoolState ledgerState + res = do + vtx <- + constructValidated + (emulatorGlobals params) + (C.Ledger.UtxoEnv (getSlot ledgerState) (emulatorPParams params) (C.Ledger.lsCertState memPool)) + (lsUTxOState memPool) + tx + applyTx params ledgerState vtx + +-- | Construct a 'AlonzoTx' from a 'Core.Tx' by setting the `IsValid` +-- flag. +-- +-- Note that this simply constructs the transaction; it does not validate +-- anything other than the scripts. Thus the resulting transaction may be +-- completely invalid. +-- +-- Copied from cardano-ledger as it was removed there +-- in https://github.com/input-output-hk/cardano-ledger/commit/721adb55b39885847562437a6fe7e998f8e48c03 +constructValidated :: + forall m. + (MonadError (ApplyTxError EmulatorEra) m) => + Globals -> + C.Ledger.UtxoEnv EmulatorEra -> + C.Ledger.UTxOState EmulatorEra -> + Core.Tx EmulatorEra -> + m (AlonzoTx EmulatorEra) +constructValidated globals (C.Ledger.UtxoEnv _ pp _) st tx = + case collectPlutusScriptsWithContext ei sysS pp tx utxo of + Left errs -> + throwError + ( ApplyTxError + ( ConwayUtxowFailure + (Core.injectFailure (UtxosFailure (Core.injectFailure $ CollectErrors errs))) + :| [] + ) + ) + Right sLst -> + let scriptEvalResult = evalPlutusScripts sLst + vTx = + AlonzoTx + (view Core.bodyTxL tx) + (view Core.witsTxL tx) + (IsValid (lift scriptEvalResult)) + (view Core.auxDataTxL tx) + in pure vTx + where + utxo = utxosUtxo st + sysS = systemStart globals + ei = epochInfo globals + lift (Passes _) = True + lift (Fails _ _) = False + +unsafeMakeValid :: CardanoTx -> OnChainTx +unsafeMakeValid (CardanoEmulatorEraTx (C.Tx txBody _)) = + let C.ShelleyTxBody _ txBody' _ _ _ _ = txBody + vtx :: Core.Tx EmulatorEra = AlonzoTx txBody' mempty (IsValid True) C.Ledger.SNothing + in OnChainTx $ unsafeMakeValidated vtx + +validateCardanoTx :: + Params -> + EmulatedLedgerState -> + CardanoTx -> + (Maybe EmulatedLedgerState, P.ValidationResult) +validateCardanoTx params ls ctx@(CardanoEmulatorEraTx tx@(C.Tx (C.TxBody bodyContent) _)) = + if map fst (C.txIns bodyContent) == [genesisTxIn] + then (Just ls, P.Success (unsafeMakeValid ctx) Map.empty) + else hasValidationErrors params ls tx + +getTxExUnitsWithLogs :: + Params -> UTxO EmulatorEra -> C.Tx C.ConwayEra -> Either P.ValidationErrorInPhase P.RedeemerReport +getTxExUnitsWithLogs params utxo (C.ShelleyTx _ tx) = + traverse (either toCardanoLedgerError Right) result + where + eg = emulatorGlobals params + ss = systemStart eg + ei = epochInfo eg + result = evalTxExUnitsWithLogs (emulatorPParams params) tx utxo ei ss + toCardanoLedgerError (ValidationFailure _ (V1.CekError ce) logs _) = + Left (P.Phase2, P.ScriptFailure (P.EvaluationError logs ("CekEvaluationFailure: " ++ show ce))) + toCardanoLedgerError e = Left (P.Phase2, P.CardanoLedgerValidationError $ Text.pack $ show e) + +createAndValidateTransactionBody :: + Params -> + P.CardanoBuildTx -> + Either CardanoLedgerError (C.TxBody C.ConwayEra) +createAndValidateTransactionBody params (P.CardanoBuildTx bodyContent) = + let bodyContent' = bodyContent {C.txProtocolParams = C.BuildTxWith $ Just $ ledgerProtocolParameters params} + in first (Right . P.TxBodyError . C.displayError) $ + C.createTransactionBody C.shelleyBasedEra bodyContent' diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/LogMessages.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/LogMessages.hs new file mode 100644 index 000000000..c31dd8ee8 --- /dev/null +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/LogMessages.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Cardano.Node.Emulator.LogMessages where + +import Cardano.Api qualified as C +import Cardano.Node.Emulator.Internal.Node.Chain (ChainEvent) +import Control.Lens.TH (makePrisms) +import Data.Aeson (Value) +import Data.Map qualified as Map +import GHC.Generics (Generic) +import Ledger (CardanoAddress, CardanoTx, getCardanoTxId, toPlutusAddress) +import Ledger.Index (UtxoIndex, ValidationError, ValidationPhase) +import Ledger.Tx.CardanoAPI (CardanoBuildTx) +import Prettyprinter (Pretty (pretty), colon, hang, viaShow, vsep, (<+>)) + +data EmulatorMsg + = GenericMsg Value + | TxBalanceMsg TxBalanceMsg + | ChainEvent ChainEvent + deriving stock (Eq, Show, Generic) + +instance Pretty EmulatorMsg where + pretty = \case + GenericMsg json -> viaShow json + TxBalanceMsg msg -> pretty msg + ChainEvent msg -> pretty msg + +data TxBalanceMsg + = BalancingUnbalancedTx CardanoBuildTx UtxoIndex + | -- | Stores the wallet address for fees + FinishedBalancing CardanoTx CardanoAddress + | SigningTx CardanoTx + | SubmittingTx CardanoTx + | -- | The amount of collateral stored in the transaction. + ValidationFailed + ValidationPhase + CardanoTx + ValidationError + C.Value + deriving stock (Eq, Show, Generic) + +instance Pretty TxBalanceMsg where + pretty = \case + BalancingUnbalancedTx tx (C.UTxO utxo) -> + hang 2 $ + vsep + [ hang 2 $ vsep ["Balancing an unbalanced transaction:", pretty tx], + hang 2 $ vsep $ "Utxo index:" : (pretty <$> Map.toList utxo) + ] + FinishedBalancing tx addr -> hang 2 $ vsep ["Finished balancing (using" <+> pretty (toPlutusAddress addr) <> "):", pretty tx] + SigningTx tx -> "Signing tx:" <+> pretty (getCardanoTxId tx) + SubmittingTx tx -> "Submitting tx:" <+> pretty (getCardanoTxId tx) + ValidationFailed p tx e _ -> "Validation error:" <+> pretty p <+> pretty (getCardanoTxId tx) <> colon <+> pretty e + +makePrisms ''TxBalanceMsg diff --git a/freer-extras/CHANGELOG.md b/freer-extras/CHANGELOG.md new file mode 100644 index 000000000..20245f22f --- /dev/null +++ b/freer-extras/CHANGELOG.md @@ -0,0 +1,7 @@ + + +# 1.2.0 — 2023-03-03 + +## Removed + +- Removed `OpenApi.ToSchema` instance for `PageQuery a`, `PageSize`, and `Page a`. diff --git a/freer-extras/LICENSE b/freer-extras/LICENSE new file mode 100644 index 000000000..0c8a80022 --- /dev/null +++ b/freer-extras/LICENSE @@ -0,0 +1,53 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of this License; and +You must cause any modified files to carry prominent notices stating that You changed the files; and +You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and +If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. + +You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. +5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/freer-extras/NOTICE b/freer-extras/NOTICE new file mode 100644 index 000000000..63df78b65 --- /dev/null +++ b/freer-extras/NOTICE @@ -0,0 +1,14 @@ +Copyright 2022 Input Output Global, Inc. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/freer-extras/README.md b/freer-extras/README.md new file mode 100644 index 000000000..863ee2830 --- /dev/null +++ b/freer-extras/README.md @@ -0,0 +1,8 @@ +## freer-extras + +This package extends [freer-simple](https://hackage.haskell.org/package/freer-simple) with + +- [Control.Monad.Freer.Extras.Log](./src/Control/Monad/Freer/Extras/Log.hs): Effects and handlers for structured logging +- [Control.Monad.Freer.Extras.Modify](./src/Control/Monad/Freer/Extras/Modify.hs): Modifying capabilities +- [Control.Monad.Freer.Extras.State](./src/Control/Monad/Freer/Extras/State.hs): State Monad functions +- [Control.Monad.Freer.Extras.Stream](./src/Control/Monad/Freer/Extras/Stream.hs): Turning a Yield effect into a stream of events diff --git a/freer-extras/changelog.d/scriv.ini b/freer-extras/changelog.d/scriv.ini new file mode 120000 index 000000000..b4aeee9df --- /dev/null +++ b/freer-extras/changelog.d/scriv.ini @@ -0,0 +1 @@ +../../scriv.ini \ No newline at end of file diff --git a/freer-extras/freer-extras.cabal b/freer-extras/freer-extras.cabal new file mode 100644 index 000000000..3719fe4c3 --- /dev/null +++ b/freer-extras/freer-extras.cabal @@ -0,0 +1,82 @@ +cabal-version: 3.8 +name: freer-extras +version: 1.4.0.0 +synopsis: Useful extensions to simple-freer +description: + freer-extras provides logging and monitoring functions extending simple-freer + +bug-reports: https://github.com/input-output-hk/plutus-apps/issues +license: Apache-2.0 +license-file: LICENSE +author: Tobias Pflug +maintainer: tobias.pflug@iohk.io +build-type: Simple + +common lang + default-language: Haskell2010 + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + GeneralizedNewtypeDeriving + ImportQualifiedPost + ScopedTypeVariables + StandaloneDeriving + + ghc-options: + -Wall -Wnoncanonical-monad-instances -Wunused-packages + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities + +library + import: lang + hs-source-dirs: src + exposed-modules: + Control.Monad.Freer.Extras + Control.Monad.Freer.Extras.Delay + Control.Monad.Freer.Extras.Log + Control.Monad.Freer.Extras.Modify + Control.Monad.Freer.Extras.Pagination + Control.Monad.Freer.Extras.State + Control.Monad.Freer.Extras.Stream + + ------------------------ + -- Non-IOG dependencies + ------------------------ + build-depends: + , aeson + , base >=4.7 && <5 + , containers + , data-default + , freer-simple + , lens + , mtl + , prettyprinter + , streaming + , text + , time-units + +test-suite freer-extras-test + import: lang + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: Control.Monad.Freer.Extras.PaginationSpec + + ---------------------------- + -- Local components + ---------------------------- + build-depends: freer-extras ^>=1.4.0 + + ------------------------ + -- Non-IOG dependencies + ------------------------ + build-depends: + , base >=4.7 && <5 + , containers + , hedgehog + , tasty + , tasty-hedgehog diff --git a/freer-extras/src/Control/Monad/Freer/Extras.hs b/freer-extras/src/Control/Monad/Freer/Extras.hs new file mode 100644 index 000000000..a9110adb2 --- /dev/null +++ b/freer-extras/src/Control/Monad/Freer/Extras.hs @@ -0,0 +1,12 @@ +module Control.Monad.Freer.Extras + ( module Control.Monad.Freer.Extras.Log, + module Control.Monad.Freer.Extras.Modify, + module Control.Monad.Freer.Extras.State, + module Control.Monad.Freer.Extras.Stream, + ) +where + +import Control.Monad.Freer.Extras.Log +import Control.Monad.Freer.Extras.Modify +import Control.Monad.Freer.Extras.State +import Control.Monad.Freer.Extras.Stream diff --git a/freer-extras/src/Control/Monad/Freer/Extras/Delay.hs b/freer-extras/src/Control/Monad/Freer/Extras/Delay.hs new file mode 100644 index 000000000..de63be1a3 --- /dev/null +++ b/freer-extras/src/Control/Monad/Freer/Extras/Delay.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} + +module Control.Monad.Freer.Extras.Delay where + +import Control.Concurrent (threadDelay) +import Control.Monad.Freer (Eff, LastMember, Member, interpret, send, type (~>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Time.Units (TimeUnit, toMicroseconds) + +data DelayEffect r where + DelayThread :: (TimeUnit a) => a -> DelayEffect () + +delayThread :: (TimeUnit a) => (Member DelayEffect effs) => a -> Eff effs () +delayThread = send . DelayThread + +handleDelayEffect :: + forall effs m. + (LastMember m effs, MonadIO m) => + Eff (DelayEffect ': effs) ~> Eff effs +handleDelayEffect = + interpret $ \case + DelayThread t -> + liftIO . threadDelay . fromIntegral . toMicroseconds $ t diff --git a/freer-extras/src/Control/Monad/Freer/Extras/Log.hs b/freer-extras/src/Control/Monad/Freer/Extras/Log.hs new file mode 100644 index 000000000..f091e2599 --- /dev/null +++ b/freer-extras/src/Control/Monad/Freer/Extras/Log.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Control.Monad.Freer.Extras.Log + ( -- $log + LogMsg (..), + LogLevel (..), + LogMessage (..), + logLevel, + logMessageContent, + logMessage, + logDebug, + logInfo, + logWarn, + logError, + + -- * Modifying logs + mapLog, + mapMLog, + + -- * Running logs + handleWriterLog, + handleLogIgnore, + handleLogTrace, + handleLogWriter, + renderLogMessages, + + -- * Observing + LogObserve (..), + ObservationHandle, + Observation (..), + observeBefore, + observeAfter, + + -- * Combinators + surround, + surroundDebug, + surroundInfo, + surroundWarn, + + -- ** Handlers + handleObserveLog, + handleObserve, + ) +where + +import Control.Lens (AReview, Prism', makeLenses, prism', review) +import Control.Monad.Freer +import Control.Monad.Freer.Extras.Modify (raiseUnder) +import Control.Monad.Freer.State (State, get, put, runState) +import Control.Monad.Freer.Writer (Writer (..), tell) +import Data.Aeson (FromJSON, ToJSON) +import Data.Foldable (for_, traverse_) +import Data.Text (Text) +import Debug.Trace qualified as Trace +import GHC.Generics (Generic) +import Prettyprinter hiding (surround) +import Prettyprinter.Render.String qualified as Render +import Prettyprinter.Render.Text qualified as Render + +-- $log +-- This module provides effects and handlers for structured logging and +-- tracing. + +{- Note [Logging and Tracing] + +This module provides two effects for structured logging, implementing a +'freer-simple' version of https://github.com/input-output-hk/iohk-monitoring-framework/tree/master/contra-tracer. + +\* 'LogMsg' and its handlers correspond to 'Control.Tracer' +\* 'LogObserve' and its handler correspond to 'Control.Tracer.Observe' + += LogMsg + +When using 'Control.Tracer' with mtl-style effects, we usually have a +'Tracer m s' at the top level with a sum type @s@, and we can use +'contramap' to get tracers for the finer-grained message +types. + +In this module we have 'Member (LogMsg s) effs' instead of the 'Tracer m s' +value. With 'freer' effects we can have many instances of 'LogMsg' in our +effects stack so we don't need to call 'contramap' or similar on +the client side. The conversion to @s@ happens in the big effect handler that +discharges all the 'LogMsg' effects. + += LogObserve + +'LogObserve' is an effect for taking measurements before and after an action, +and recording the difference between them. It is implemented using two markers, +'LObserveBefore' and 'LObserveAfter'. + +Some effects such as Error, Prompt may short-circuit the action, so that the +LObserveAfter marker is never encountered by the handler. 'handleObserve' deals +with this by keeping a stack of unmatched 'LObserveBefore' markers and popping +as many items of the stack as needed whenever 'LObserveAfter' is run. It works +even if the topmost LObserveAfter is never seen, by popping all remaining items +off the stack at the end. + +'LogObserve' supports measures taken on the call site and on the +interpretation site. + +\* Interpretation-site measures are produced with the second argument to + 'handleObserve' +\* Call-site measures can be provided using the type parameter a in the + constructors of 'LogObserve' + +-} + +data LogMsg a r where + LMessage :: LogMessage a -> LogMsg a () + +-- | An abstract type used to tie the beginning and end of observations +-- together. +newtype ObservationHandle = ObservationHandle Integer + +data LogObserve a r where + ObserveBefore :: a -> LogObserve a ObservationHandle + ObserveAfter :: Maybe a -> ObservationHandle -> LogObserve a () + +-- | The severity level of a log message +-- See https://en.wikipedia.org/wiki/Syslog#Severity_level +data LogLevel + = Debug + | Info + | Notice + | Warning + | Error + | Critical + | Alert + | Emergency + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Pretty LogLevel where + pretty = \case + Debug -> "[DEBUG]" + Info -> "[INFO]" + Notice -> "[NOTICE]" + Warning -> "[WARNING]" + Error -> "[ERROR]" + Critical -> "[CRITICAL]" + Alert -> "[ALERT]" + Emergency -> "[EMERGENCY]" + +data LogMessage a = LogMessage {_logLevel :: LogLevel, _logMessageContent :: a} + deriving stock (Show, Eq, Ord, Generic, Functor, Foldable, Traversable) + deriving anyclass (ToJSON, FromJSON) + +makeLenses ''LogMessage + +logMessage :: LogLevel -> Prism' (LogMessage a) a +logMessage lvl = prism' (LogMessage lvl) (\case LogMessage lvl' a | lvl' == lvl -> Just a; _ -> Nothing) + +instance (Pretty a) => Pretty (LogMessage a) where + pretty LogMessage {_logLevel, _logMessageContent} = + pretty _logLevel <+> hang 0 (pretty _logMessageContent) + +logDebug :: forall a effs. (Member (LogMsg a) effs) => a -> Eff effs () +logDebug m = send $ LMessage (LogMessage Debug m) + +logWarn :: forall a effs. (Member (LogMsg a) effs) => a -> Eff effs () +logWarn m = send $ LMessage (LogMessage Warning m) + +logInfo :: forall a effs. (Member (LogMsg a) effs) => a -> Eff effs () +logInfo m = send $ LMessage (LogMessage Info m) + +logError :: forall a effs. (Member (LogMsg a) effs) => a -> Eff effs () +logError m = send $ LMessage (LogMessage Error m) + +-- | Re-interpret a logging effect by mapping the +-- log messages. +-- (Does the same thing as 'Covariant.contramap' for +-- 'Control.Tracer.Trace') +mapLog :: + forall a b effs. + (Member (LogMsg b) effs) => + (a -> b) -> + LogMsg a + ~> Eff effs +mapLog f = \case + LMessage msg -> send $ LMessage (fmap f msg) + +-- | Re-interpret a logging effect by mapping the +-- log messages. Can use other effects. +mapMLog :: + forall a b effs. + (Member (LogMsg b) effs) => + (a -> Eff effs b) -> + LogMsg a + ~> Eff effs +mapMLog f = \case + LMessage msg -> traverse f msg >>= send . LMessage + +-- | Pretty-print the log messages +renderLogMessages :: + forall a effs. + ( Member (LogMsg Text) effs, + Pretty a + ) => + LogMsg a + ~> Eff effs +renderLogMessages = + mapLog (Render.renderStrict . layoutPretty defaultLayoutOptions . pretty) + +-- | Re-interpret a 'Writer' effect by writing the events to the log +handleWriterLog :: + forall a f effs. + ( Member (LogMsg a) effs, + Traversable f + ) => + (a -> LogLevel) -> + Eff (Writer (f a) ': effs) + ~> Eff effs +handleWriterLog f = interpret $ \case + Tell es -> traverse_ (\a -> send $ LMessage $ LogMessage (f a) a) es + +-- | Re-interpret a 'Log' effect with a 'Writer' +handleLogWriter :: + forall a w effs. + ( Member (Writer w) effs + ) => + AReview w (LogMessage a) -> + LogMsg a + ~> Eff effs +handleLogWriter p = \case + LMessage msg -> tell @w (review p msg) + +-- | Ignore all log messages. +handleLogIgnore :: Eff (LogMsg a ': effs) ~> Eff effs +handleLogIgnore = interpret $ \case + LMessage _ -> pure () + +-- | Write the log to stdout using 'Debug.Trace.trace' +handleLogTrace :: (Pretty a) => Eff (LogMsg a ': effs) ~> Eff effs +handleLogTrace = interpret $ \case + LMessage msg -> Trace.trace (Render.renderString . layoutPretty defaultLayoutOptions . pretty $ msg) (pure ()) + +-- | Write a log message before and after an action. Consider using +-- 'observeBefore' and 'observeAfter' directly if you need more control +-- over the values that are observed at the call site. +surround :: forall v a effs. (Member (LogObserve v) effs) => v -> Eff effs a -> Eff effs a +surround v action = do + i <- send $ ObserveBefore v + result <- action + send @(LogObserve v) $ ObserveAfter Nothing i + pure result + +-- | @surroundInfo = surround Info@ +surroundInfo :: (Member (LogObserve (LogMessage v)) effs) => v -> Eff effs a -> Eff effs a +surroundInfo = surround . LogMessage Info + +-- | @surroundDebug = surround Debug@ +surroundDebug :: (Member (LogObserve (LogMessage v)) effs) => v -> Eff effs a -> Eff effs a +surroundDebug = surround . LogMessage Debug + +-- | @surroundWarn = surround Warn@ +surroundWarn :: (Member (LogObserve (LogMessage v)) effs) => v -> Eff effs a -> Eff effs a +surroundWarn = surround . LogMessage Warning + +-- | How did the observed action end +data ExitMode + = -- | The action was run to completion + Regular + | -- | Execution of the observed action was cut short. This can happen if you use 'LogObserve' in combination with 'Error', 'NonDet', 'Prompt' or similar effects. + Irregular + deriving (Eq, Ord, Show) + +-- | An observation with measurements before and after running an action. +data Observation v s = Observation + { -- | Call-site information about the start of the observation + obsLabelStart :: v, + -- | Measurement taken before running the action + obsStart :: s, + -- | Call-site information about the end of the observation + obsLabelEnd :: Maybe v, + -- | 'ExitMode' of the action. + obsExit :: ExitMode + } + +-- | An 'Observation' that doesn't have an 'obsEnd' value yet. +data PartialObservation v s = PartialObservation + { obsMsg :: v, + obsValue :: s, + obsDepth :: Integer + } + +-- | State of partial observations +data ObsState v s = ObsState + { obsMaxDepth :: Integer, + obsPartials :: [PartialObservation v s] + } + +initialState :: ObsState v s +initialState = ObsState 0 [] + +-- see note [Logging and Tracing] + +-- | Handle the 'LogObserve' effect by recording observations +-- @s@ before and after the observed action, and turning +-- them into 'LogMessage (Observation s)' values. +handleObserve :: + forall v s effs. + -- | How to get the current 's' + (v -> Eff effs s) -> + (Observation v s -> Eff effs ()) -> -- what to do with the observation + Eff (LogObserve v ': effs) + ~> Eff effs +handleObserve getCurrent handleObs = + handleFinalState + . runState @(ObsState v s) initialState + . handler + . raiseUnder @effs @(LogObserve v) @(State (ObsState v s)) + where + -- empty the stack of partial observations at the very end. + handleFinalState :: forall a. Eff effs (a, ObsState v s) -> Eff effs a + handleFinalState action = do + (result, finalState) <- action + _ <- handleObserveAfter Nothing finalState 0 + pure result + + -- when an action with the given depth is finished, take the final + -- measurement and clear the stack of partial observations. + handleObserveAfter :: Maybe v -> ObsState v s -> Integer -> Eff effs (ObsState v s) + handleObserveAfter v' ObsState {obsPartials} i = do + let (finishedPartials, remainingPartials) = span ((<=) i . obsDepth) obsPartials + for_ finishedPartials $ \PartialObservation {obsMsg, obsValue, obsDepth} -> do + -- we assume that a 'PartialObservation' was completed + -- regularly if it is handled at its own depth level. + -- If the @obsDepth@ is greater than @i@ then one or more + -- 'LObserveAfter' calls were skipped, which we note with + -- 'Irregular'. + let exitMode = if obsDepth == i then Regular else Irregular + message = + Observation + { obsLabelStart = obsMsg, + obsStart = obsValue, + obsExit = exitMode, + obsLabelEnd = case exitMode of Regular -> v'; Irregular -> Nothing + } + handleObs message + pure ObsState {obsMaxDepth = i - 1, obsPartials = remainingPartials} + + handleObserveBefore :: v -> ObsState v s -> Eff effs (ObsState v s, ObservationHandle) + handleObserveBefore v ObsState {obsPartials, obsMaxDepth} = do + current <- getCurrent v + let newMaxDepth = obsMaxDepth + 1 + msg = + PartialObservation + { obsMsg = v, + obsValue = current, + obsDepth = newMaxDepth + } + newState = ObsState {obsMaxDepth = newMaxDepth, obsPartials = msg : obsPartials} + pure (newState, ObservationHandle newMaxDepth) + + handler :: + Eff (LogObserve v ': State (ObsState v s) ': effs) + ~> Eff (State (ObsState v s) ': effs) + handler = interpret $ \case + ObserveBefore vl -> do + currentState <- get @(ObsState v s) + (newState, handle) <- raise (handleObserveBefore vl currentState) + put newState + pure handle + ObserveAfter v' (ObservationHandle i) -> do + currentState <- get @(ObsState v s) + newState <- raise (handleObserveAfter v' currentState i) + put newState + +-- | Interpret the 'LogObserve' effect by logging a "start" message +-- before the action and an "end" message after the action. +handleObserveLog :: + forall effs. + (Member (LogMsg Text) effs) => + Eff (LogObserve (LogMessage Text) ': effs) + ~> Eff effs +handleObserveLog = + handleObserve (\_ -> pure ()) handleAfter + . interpose handleBefore + where + handleBefore :: LogObserve (LogMessage Text) ~> Eff (LogObserve (LogMessage Text) ': effs) + handleBefore = \case + ObserveBefore msg -> do + let msg' = fmap (<> " start") msg + send $ LMessage msg' + send $ ObserveBefore msg + ObserveAfter v' i -> send @(LogObserve (LogMessage Text)) $ ObserveAfter v' i + handleAfter Observation {obsLabelStart, obsExit} = do + let msg' = + fmap + (\lbl -> case obsExit of Regular -> lbl <> " end"; Irregular -> lbl <> " end (irregular)") + obsLabelStart + send $ LMessage msg' + +observeBefore :: (Member (LogObserve a) effs) => a -> Eff effs ObservationHandle +observeBefore a = send (ObserveBefore a) + +observeAfter :: (Member (LogObserve a) effs) => Maybe a -> ObservationHandle -> Eff effs () +observeAfter a b = send (ObserveAfter a b) diff --git a/freer-extras/src/Control/Monad/Freer/Extras/Modify.hs b/freer-extras/src/Control/Monad/Freer/Extras/Modify.hs new file mode 100644 index 000000000..c986bf61d --- /dev/null +++ b/freer-extras/src/Control/Monad/Freer/Extras/Modify.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.Monad.Freer.Extras.Modify + ( -- * change the list of effects + mapEffs, + + -- * under functions + UnderN (..), + under, + + -- * weaken functions + CanWeakenEnd (..), + weakenUnder, + weakenNUnder, + weakenMUnderN, + + -- * raise functions + raiseEnd, + raiseUnder, + raiseUnder2, + raise2Under, + raiseNUnder, + raiseMUnderN, + + -- * zoom functions + handleZoomedState, + handleZoomedError, + handleZoomedWriter, + handleZoomedReader, + + -- * manipulation + writeIntoState, + stateToMonadState, + monadStateToState, + errorToMonadError, + wrapError, + ) +where + +import Control.Lens hiding (under) +import Control.Monad.Except qualified as MTL +import Control.Monad.Freer +import Control.Monad.Freer.Error +import Control.Monad.Freer.Internal +import Control.Monad.Freer.Reader +import Control.Monad.Freer.State +import Control.Monad.Freer.Writer +import Control.Monad.State qualified as MTL + +mapEffs :: (Union effs ~> Union effs') -> Eff effs ~> Eff effs' +mapEffs f = loop + where + loop = \case + Val a -> pure a + E u q -> E (f u) (tsingleton $ qComp q loop) + +under :: (Union effs ~> Union effs') -> Union (a ': effs) ~> Union (a ': effs') +under f u = case decomp u of + Left u' -> weaken (f u') + Right t -> inj t + +class UnderN as where + underN :: (Union effs ~> Union effs') -> Union (as :++: effs) ~> Union (as :++: effs') + +instance UnderN '[] where + underN f = f + +instance (UnderN as) => UnderN (a ': as) where + underN f = under (underN @as f) + +{- Note [Various raising helpers] +These are all to help with the issue where you have something of type + +Eff effs a + +where effs is some *fixed* list of effects. You may then need to insert +more effects *under* effs to interpret them in terms of. It turns out that +inserting effects at the *end* of the list is tricky. + +I have no idea what I'm doing, these are partially stolen from freer-simple/polysemy +with a lot of hacking around. + +The first instance of CanWeakenEnd is for the case where the fixed list has length 1. +The second instance is for cases where the fixed list has a length of 2 or more, +hence the double cons in the types to prevent overlap with the first instance. +-} +class CanWeakenEnd as effs where + weakenEnd :: Union as ~> Union effs + +instance (effs ~ (a ': effs')) => CanWeakenEnd '[a] effs where + weakenEnd u = inj (extract u) + +instance (effs ~ (a ': effs'), CanWeakenEnd (b ': as) effs') => CanWeakenEnd (a ': b ': as) effs where + weakenEnd = under weakenEnd + +weakenUnder :: forall effs a b. Union (a ': effs) ~> Union (a ': b ': effs) +weakenUnder = under weaken + +weakenNUnder :: + forall effs' effs a. (Weakens effs') => Union (a ': effs) ~> Union (a ': (effs' :++: effs)) +weakenNUnder = under (weakens @effs' @effs) + +-- basically applies `under` n times to `weaken` composed m times, n = length as, m = length effs' +weakenMUnderN :: + forall effs' as effs. + (UnderN as, Weakens effs') => + Union (as :++: effs) ~> Union (as :++: (effs' :++: effs)) +weakenMUnderN = underN @as (weakens @effs' @effs) + +raiseEnd :: forall effs as. (CanWeakenEnd as effs) => Eff as ~> Eff effs +raiseEnd = mapEffs weakenEnd + +raiseUnder :: forall effs a b. Eff (a ': effs) ~> Eff (a ': b ': effs) +raiseUnder = mapEffs weakenUnder + +raiseUnder2 :: forall effs a b c. Eff (a ': b ': effs) ~> Eff (a ': b ': c ': effs) +raiseUnder2 = mapEffs (under $ under weaken) + +raise2Under :: forall effs a b c. Eff (a ': effs) ~> Eff (a ': b ': c ': effs) +raise2Under = mapEffs (under $ weaken . weaken) + +raiseNUnder :: + forall effs' effs a. (Weakens effs') => Eff (a ': effs) ~> Eff (a ': (effs' :++: effs)) +raiseNUnder = mapEffs (weakenNUnder @effs' @effs @a) + +-- | Raise m effects under the top n effects +raiseMUnderN :: + forall effs' as effs. + (UnderN as, Weakens effs') => + Eff (as :++: effs) ~> Eff (as :++: (effs' :++: effs)) +raiseMUnderN = mapEffs (weakenMUnderN @effs' @as @effs) + +-- | Handle a 'State' effect in terms of a "larger" 'State' effect from which we have a lens. +handleZoomedState :: (Member (State s2) effs) => Lens' s2 s1 -> (State s1 ~> Eff effs) +handleZoomedState l = \case + Get -> view l <$> get + Put v -> modify (set l v) + +-- | Handle a 'Writer' effect in terms of a "larger" 'Writer' effect from which we have a review. +handleZoomedWriter :: (Member (Writer s2) effs) => AReview s2 s1 -> (Writer s1 ~> Eff effs) +handleZoomedWriter p = \case + Tell w -> tell (review p w) + +-- | Handle an 'Error' effect in terms of a "larger" 'Error' effect from which we have a review. +handleZoomedError :: (Member (Error s2) effs) => AReview s2 s1 -> (Error s1 ~> Eff effs) +handleZoomedError p = \case + Error e -> throwError (review p e) + +-- | Handle a 'Reader' effect in terms of a "larger" 'Reader' effect from which we have a getter. +handleZoomedReader :: (Member (Reader s2) effs) => Getter s2 s1 -> (Reader s1 ~> Eff effs) +handleZoomedReader g = \case + Ask -> view g <$> ask + +-- | Handle a 'Writer' effect in terms of a "larger" 'State' effect from which we have a setter. +writeIntoState :: + (Monoid s1, Member (State s2) effs) => + Setter' s2 s1 -> + (Writer s1 ~> Eff effs) +writeIntoState s = \case + Tell w -> modify (\st -> st & s <>~ w) + +-- | Handle a 'State' effect in terms of a monadic effect which has a 'MTL.MonadState' instance. +stateToMonadState :: + (MTL.MonadState s m) => + (State s ~> m) +stateToMonadState = \case + Get -> MTL.get + Put v -> MTL.put v + +monadStateToState :: + (Member (State s) effs) => + MTL.State s a -> + Eff effs a +monadStateToState a = do + s1 <- get + let (r, s2) = MTL.runState a s1 + put s2 + return r + +-- | Handle an 'Error' effect in terms of a monadic effect which has a 'MTL.MonadError' instance. +errorToMonadError :: + (MTL.MonadError e m) => + (Error e ~> m) +errorToMonadError = \case + Error e -> MTL.throwError e + +-- | Transform an error type +wrapError :: + forall e f effs. + (Member (Error f) effs) => + (e -> f) -> + Eff (Error e ': effs) + ~> Eff effs +wrapError f = flip handleError (throwError @f . f) diff --git a/freer-extras/src/Control/Monad/Freer/Extras/Pagination.hs b/freer-extras/src/Control/Monad/Freer/Extras/Pagination.hs new file mode 100644 index 000000000..2bae7de1f --- /dev/null +++ b/freer-extras/src/Control/Monad/Freer/Extras/Pagination.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +{- + +Pagination allows to return a subset of results through pages. Once the first +page was requested, we can request the next ones until we get empty results. + +There are multiple strategies for implementation pagination, such as Offset +Pagination and Seek Pagination. Offset Pagination is the easiest to implement +and use. However, it is not performant for large offset values and it is not +consistent if new items are inserted in the database while we are querying. +For these reasons, we decided to use Seek Pagination which doesn't suffer from +those drawbacks. Seek Pagination works as follows. For a given page request, we +need to provide the number of items per page and last element we queried (can +be Nothing). We suppose the elements are ordered in ascending order. + +Here's a simple illustrative example: + +\* Suppose we have the following items in the database [1..100]. +\* We first request the 50 first items. +\* We obtain the first page containing [1..50]. +\* To request the next page, we request 50 items after the last item of the + previous page (which is 50). +\* We obtain the second page containing [51..100]. +\* Since we don't know this was the last page, we would request the next 50 + items after the last item (which is 100). +\* We obtain a page with no elements, thus we don't need to query for more pages. +-} +module Control.Monad.Freer.Extras.Pagination + ( PageQuery (..), + Page (..), + PageSize (..), + pageOf, + ) +where + +import Control.Monad (guard) +import Data.Aeson (FromJSON, ToJSON) +import Data.Default (Default (..)) +import Data.List.NonEmpty qualified as L +import Data.Maybe (isJust, listToMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) +import Numeric.Natural (Natural) + +-- | Query parameters for pagination. +data PageQuery a = PageQuery + { -- | Number of items per page. + pageQuerySize :: PageSize, + -- | Last item of the queried page. + pageQueryLastItem :: Maybe a + } + deriving stock (Eq, Ord, Show, Generic, Functor) + deriving anyclass (ToJSON, FromJSON) + +instance Default (PageQuery a) where + def = PageQuery def Nothing + +newtype PageSize = PageSize {getPageSize :: Natural} + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + deriving newtype (Num) + +instance Default PageSize where + def = PageSize 50 + +-- | Part of a collection. +data Page a = Page + { -- | The 'PageQuery' which was used to request this 'Page'. + currentPageQuery :: PageQuery a, + -- | The 'PageQuery' to use to request the next 'Page'. Nothing if we requested the last page. + nextPageQuery :: Maybe (PageQuery a), + -- | Items in the current 'Page'. + pageItems :: [a] + } + deriving stock (Eq, Ord, Show, Generic, Functor) + deriving anyclass (ToJSON, FromJSON) + +-- | Given a 'Set', request the 'Page' with the given 'PageQuery'. +pageOf :: + (Eq a) => + -- | Pagination query parameters. + PageQuery a -> + Set a -> + Page a +pageOf pageQuery@PageQuery {pageQuerySize = PageSize ps, pageQueryLastItem} items = + let ps' = fromIntegral ps + -- The extract the @PageSize + 1@ next elements after the last query + -- element. The @+1@ allows to now if there is a next page or not. + pageItems = case pageQueryLastItem of + Nothing -> take (ps' + 1) $ Set.toList items + Just i -> take (ps' + 1) $ drop 1 $ dropWhile ((/=) i) $ Set.toList items + + nextLastItem = + guard (length items > fromIntegral ps) + >> L.nonEmpty pageItems + >>= listToMaybe . L.tail . L.reverse + in Page + { currentPageQuery = pageQuery, + nextPageQuery = fmap (PageQuery (PageSize ps) . Just) nextLastItem, + pageItems = if isJust nextLastItem then init pageItems else pageItems + } diff --git a/freer-extras/src/Control/Monad/Freer/Extras/State.hs b/freer-extras/src/Control/Monad/Freer/Extras/State.hs new file mode 100644 index 000000000..26f047b4e --- /dev/null +++ b/freer-extras/src/Control/Monad/Freer/Extras/State.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} + +module Control.Monad.Freer.Extras.State + ( use, + assign, + modifying, + ) +where + +import Control.Lens (ASetter, Getting, over, set, view) +import Control.Monad.Freer (Eff, Member) +import Control.Monad.Freer.State (State, get, gets, put) + +use :: (Member (State s) effs) => Getting a s a -> Eff effs a +use accessor = gets (view accessor) + +assign :: (Member (State s) effs) => ASetter s s a b -> b -> Eff effs () +assign accessor value = get >>= put . set accessor value + +modifying :: (Member (State s) effs) => ASetter s s a b -> (a -> b) -> Eff effs () +modifying accessor f = get >>= put . over accessor f diff --git a/freer-extras/src/Control/Monad/Freer/Extras/Stream.hs b/freer-extras/src/Control/Monad/Freer/Extras/Stream.hs new file mode 100644 index 000000000..48402a015 --- /dev/null +++ b/freer-extras/src/Control/Monad/Freer/Extras/Stream.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +{- Interpreting the 'Yield' effect as a stream -} +module Control.Monad.Freer.Extras.Stream + ( runStream, + ) +where + +import Control.Monad.Freer +import Control.Monad.Freer.Coroutine (Status (..), Yield, runC) +import Streaming (Stream) +import Streaming.Prelude (Of) +import Streaming.Prelude qualified as S + +-- | Turn the @Yield e ()@ effect into a pull-based stream +-- of @e@ events. +runStream :: + forall e a effs. + Eff (Yield e () ': effs) a -> + Stream (Of e) (Eff effs) a +runStream action = + let f :: Eff effs (Status effs e () a) -> Eff effs (Either a (e, Eff effs (Status effs e () a))) + f a = do + result <- a + case result of + Done b -> pure (Left b) + Continue e cont -> pure $ Right (e, cont ()) + in S.unfoldr f (runC action) diff --git a/freer-extras/test/Control/Monad/Freer/Extras/PaginationSpec.hs b/freer-extras/test/Control/Monad/Freer/Extras/PaginationSpec.hs new file mode 100644 index 000000000..06bc222db --- /dev/null +++ b/freer-extras/test/Control/Monad/Freer/Extras/PaginationSpec.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Control.Monad.Freer.Extras.PaginationSpec (tests) where + +import Control.Monad (forM_) +import Control.Monad.Freer.Extras.Pagination + ( Page (nextPageQuery, pageItems), + PageQuery (PageQuery), + pageOf, + ) +import Data.List (sort) +import Data.Maybe (listToMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Hedgehog (Property, forAll, property, (===)) +import Hedgehog qualified +import Hedgehog.Gen as Gen +import Hedgehog.Range as Gen +import Test.Tasty +import Test.Tasty.Hedgehog (testProperty) + +tests :: TestTree +tests = do + testGroup + "pagination" + [ testGroup + "pageOf" + [ testProperty + "size of pageItems of all pages should be less or equal than total number of items in list" + pageItemsSizeLessOrEqualGenItemsSizeSpec, + testProperty + "size of pageItems of all pages should be less or equal than requested page size" + pageItemsSizeLessOrEqualThanRequestedPageSize, + testProperty + "last page should have no next page" + lastPageShouldHaveNoNextPageQuerySpec, + testProperty + "concat items for all pages should be the same as generated items" + pageItemsEqualGenItemsSpec, + testProperty + "page items should be sorted in ascending order" + pageItemsSortedAscOrderSpec, + testProperty + "page size equal to total number of items in list should return a single page" + pageSizeEqualToTotalItemsSizeShouldReturnOnePage + ] + ] + +-- | The length of field 'pageItems' should be less or equal than total number +-- of items. +pageItemsSizeLessOrEqualGenItemsSizeSpec :: Property +pageItemsSizeLessOrEqualGenItemsSizeSpec = property $ do + items <- forAll $ Gen.set (Gen.linear 1 10) $ Gen.int (Gen.linear 0 100) + pageSize <- forAll $ Gen.int (Gen.linear 1 20) + forM_ (getAllPages (PageQuery (fromIntegral pageSize) Nothing) items) $ \page -> do + Hedgehog.assert $ length (pageItems page) <= length items + +-- | The length of field 'pageItems' should be less or equal than the requested +-- 'PageSize'. +pageItemsSizeLessOrEqualThanRequestedPageSize :: Property +pageItemsSizeLessOrEqualThanRequestedPageSize = property $ do + items <- forAll $ Gen.set (Gen.linear 1 10) $ Gen.int (Gen.linear 0 100) + pageSize <- forAll $ Gen.int (Gen.linear 1 20) + forM_ (getAllPages (PageQuery (fromIntegral pageSize) Nothing) items) $ \page -> do + Hedgehog.assert $ length (pageItems page) <= pageSize + +-- | The last 'Page' should have a number of page items less or equal than +-- requested 'PageSize' and it's 'nextPageQuery' field should be Nothing. +lastPageShouldHaveNoNextPageQuerySpec :: Property +lastPageShouldHaveNoNextPageQuerySpec = property $ do + items <- forAll $ Gen.set (Gen.linear 1 10) $ Gen.int (Gen.linear 0 100) + pageSize <- forAll $ Gen.int (Gen.linear 1 20) + let lastPageM = listToMaybe $ reverse $ getAllPages (PageQuery (fromIntegral pageSize) Nothing) items + case lastPageM of + Nothing -> Hedgehog.assert False + Just lastPage -> do + Hedgehog.assert $ length (pageItems lastPage) <= pageSize + nextPageQuery lastPage === Nothing + +-- | Concatenating all 'pageItems' of all 'Page's should be equal to the +-- generated input list. +pageItemsEqualGenItemsSpec :: Property +pageItemsEqualGenItemsSpec = property $ do + items <- forAll $ Gen.set (Gen.linear 1 10) $ Gen.int (Gen.linear 0 100) + let pages = getAllPages (PageQuery 1 Nothing) items + Set.fromList (concatMap pageItems pages) === Set.fromList (Set.toList items) + +-- | The elemens in all 'pageItems' of all 'Page's should be sorted in +-- ascending order. +pageItemsSortedAscOrderSpec :: Property +pageItemsSortedAscOrderSpec = property $ do + items <- forAll $ Gen.set (Gen.linear 1 10) $ Gen.int (Gen.linear 0 100) + let pages = getAllPages (PageQuery 1 Nothing) items + concatMap pageItems pages === sort (concatMap pageItems pages) + +pageSizeEqualToTotalItemsSizeShouldReturnOnePage :: Property +pageSizeEqualToTotalItemsSizeShouldReturnOnePage = property $ do + items <- forAll $ Gen.set (Gen.linear 1 10) $ Gen.int (Gen.linear 0 100) + let pages = getAllPages (PageQuery (fromIntegral $ length items) Nothing) items + length pages === 1 + +getAllPages :: + (Eq a) => + PageQuery a -> + Set a -> + [Page a] +getAllPages pq items = + let page = pageOf pq items + in case nextPageQuery page of + Nothing -> [page] + Just newPageQuery -> do + let nextPages = getAllPages newPageQuery items + page : nextPages diff --git a/freer-extras/test/Spec.hs b/freer-extras/test/Spec.hs new file mode 100644 index 000000000..70af0ae42 --- /dev/null +++ b/freer-extras/test/Spec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +module Main (main) where + +import Control.Monad.Freer.Extras.PaginationSpec qualified as PaginationSpec +import Test.Tasty + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "tests" + [ PaginationSpec.tests + ] diff --git a/hie.yaml b/hie.yaml index df1dae54b..33c879b90 100644 --- a/hie.yaml +++ b/hie.yaml @@ -5,3 +5,24 @@ cradle: - path: "./tests/" component: "cooked-validators:test:spec" + + - path: "cardano-node-emulator/src" + component: "lib:cardano-node-emulator" + + - path: "freer-extras/src" + component: "lib:freer-extras" + + - path: "freer-extras/test" + component: "freer-extras:test:freer-extras-test" + + - path: "plutus-ledger/src" + component: "lib:plutus-ledger" + + - path: "plutus-ledger/test" + component: "plutus-ledger:test:plutus-ledger-test" + + - path: "plutus-script-utils/src" + component: "lib:plutus-script-utils" + + - path: "plutus-script-utils/test" + component: "plutus-script-utils:test:plutus-ledger-test" diff --git a/plutus-ledger/ARCHITECTURE.adoc b/plutus-ledger/ARCHITECTURE.adoc new file mode 100644 index 000000000..c54788b29 --- /dev/null +++ b/plutus-ledger/ARCHITECTURE.adoc @@ -0,0 +1,6 @@ +=== `plutus-ledger` + +This defines our model of an Extended UTXO ledger, including: + +- The types that describe transactions, pending transactions, keys, currencies, etc. +- Functions that implement the ledger validation rules. diff --git a/plutus-ledger/CHANGELOG.md b/plutus-ledger/CHANGELOG.md new file mode 100644 index 000000000..4912f82ac --- /dev/null +++ b/plutus-ledger/CHANGELOG.md @@ -0,0 +1,79 @@ + + +# 1.2.0 — 2023-03-03 + +## Removed + +- Removed `OpenApi.ToSchema` instance for a lot of ledger, plutus and cardano types. + +- Moved `Ledger.Value` to `Plutus.Scripts.Utils.Value` +- Moved `Ledger.Ada` to `Plutus.Scripts.Utils.Ada` + +- Remove `unspentOutputsTx` and `spentOutputs`. +- Remove `cardanoApiTx`, `emulatorTx`, `onCardanoTx`, `cardanoTxMap`, `addSignature`, `addSignature'`, `txOutRefs`, `unspentOutputsTx`, `txId`. +- Remove `CardanoTx(EmulatorTx, CardanoApiTx)`. +- Remove `toCardanoTxBody`, `toCardanoTxBodyContent`, `toCardanoTxInWitness`, `toCardanoMintValue`. +- Remove `Tx` and `TxStripped` types and all related functions. + +## Added + +- Added `Ledger.Value.CardanoAPI` for working with the `Value` type from `cardano-api`. + +## Changed + +- Moved to using the `Value` type from `cardano-api` instead of the one from `plutus-core`. + +- Renamed `SomeCardanoApiTx(SomeTx)` to `CardanoTx(CardanoTx)`. +- Renamed `CardanoApiEmulatorEraTx` to `CardanoEmulatorEraTx`. + + +# 1.1.0 — 2023-01-12 + +## Removed + +- Moved to `cardano-node-emulator` package: + - `Ledger.TimeSlot` to `Cardano.Node.Emulator.TimeSlot` + - `Ledger.Params` to `Cardano.Node.Emulator.Params` + - `Ledger.Generators` to `Cardano.Node.Emulator.Generators` + - `Ledger.Fee` to `Cardano.Node.Emulator.Fee` + - `Ledger.Validation` to `Cardano.Node.Emulator.Validation` + - `Wallet.Emulator.Chain` to `Cardano.Node.Emulator.Chain` + +## Added + +- `minAdaTxOut`, computes the minimum amount of Ada required for a `TxOut` more + precisely, by taking the params and the `TxOut`. + +- Added `makeAutoBalancedTransactionWithUtxoProvider` and related functions to `Ledger.Fee`. + +- `Ledger.Address.CardanoAddress` an alias to address in the latest era +- `Ledger.Address.cardanoAddressCredential` to retrieve `plutus` credentials + from a Cardano address +- `Ledger.Address.cardanoStakingCredential` to retrieve `plutus` staking credentials + from a Cardano address +- `Ledger.Address.cardanoStakingCredential` to retrieve `plutus` `PubKeyHash` + from a Cardano address +- `Ledger.Address.toPlutusAddress` to get a `plutus` address from a Cardano one + (it replaces `Ledger.Tx.CardanoAPI.fromCardanoAddressInEra`) + +## Changed + +- `minAdaTxOut` is now renamed `minAdaTxOutEstimated`. + +- Moved `adjustTxOut` into `Ledger.Index` +- Balancing no longer logs if and which inputs and outputs were added. + +- Moved to `Ledger.Tx.CardanoAPI`: + - `Ledger.Validation.getRequiredSigners` + - `Ledger.Validation.fromPlutusIndex` + - `Ledger.Validation.fromPlutusTxOut` + - `Ledger.Validation.fromPlutusTxOutRef` + +- `Ledger.Address` now priviledges `cardano-api` addresses instead of `plutus-api` addresses. + +## Deprecated + +- `fromCardanoAddressInEra`, `fromCardanoAddress`, `fromCardanoPaymentCredential`, + `fromCardanoPaymentKeyHash`, `fromCardanoScriptHash`, + `fromCardanoStakeAddressReference`and `fromCardanoStakeCredential` from `Ledger.Tx.CardanoAPI` + that shouldn't be used now that we use `cardano-api` adress in the emulator. diff --git a/plutus-ledger/LICENSE b/plutus-ledger/LICENSE new file mode 100644 index 000000000..0c8a80022 --- /dev/null +++ b/plutus-ledger/LICENSE @@ -0,0 +1,53 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of this License; and +You must cause any modified files to carry prominent notices stating that You changed the files; and +You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and +If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. + +You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. +5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/plutus-ledger/NOTICE b/plutus-ledger/NOTICE new file mode 100644 index 000000000..63df78b65 --- /dev/null +++ b/plutus-ledger/NOTICE @@ -0,0 +1,14 @@ +Copyright 2022 Input Output Global, Inc. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/plutus-ledger/README.md b/plutus-ledger/README.md new file mode 100644 index 000000000..818dfb911 --- /dev/null +++ b/plutus-ledger/README.md @@ -0,0 +1,3 @@ +## Wallet API + +This contains a draft of the Plutus wallet API and an emulator for testing contracts. diff --git a/plutus-ledger/changelog.d/20230412_134023_sjoerd.visscher_PLT_5294_replace_more_plutus_types.md b/plutus-ledger/changelog.d/20230412_134023_sjoerd.visscher_PLT_5294_replace_more_plutus_types.md new file mode 100644 index 000000000..80d052fbc --- /dev/null +++ b/plutus-ledger/changelog.d/20230412_134023_sjoerd.visscher_PLT_5294_replace_more_plutus_types.md @@ -0,0 +1,9 @@ +### Removed + +- Removed `TxIn` and `TxInput` types. + +### Changed + +- Replaced the `UtxoIndex` type with `UTxO` from `cardano-api`. +- Replaced many uses of `TxId` with `TxId` from `cardano-api`. +- Replaced many uses of `TxOutRef` with `TxIn` from `cardano-api`. diff --git a/plutus-ledger/changelog.d/20230623_134342_sjoerd.visscher_PLT_5775_plutus-ledger_refactoring.md b/plutus-ledger/changelog.d/20230623_134342_sjoerd.visscher_PLT_5775_plutus-ledger_refactoring.md new file mode 100644 index 000000000..49a4cef22 --- /dev/null +++ b/plutus-ledger/changelog.d/20230623_134342_sjoerd.visscher_PLT_5775_plutus-ledger_refactoring.md @@ -0,0 +1,4 @@ +### Removed + +- Removed `Ledger.Tokens` +- Removed lots of functions from `Ledger.AddressMap` and `Ledger.Blockchain`. diff --git a/plutus-ledger/changelog.d/scriv.ini b/plutus-ledger/changelog.d/scriv.ini new file mode 120000 index 000000000..b4aeee9df --- /dev/null +++ b/plutus-ledger/changelog.d/scriv.ini @@ -0,0 +1 @@ +../../scriv.ini \ No newline at end of file diff --git a/plutus-ledger/plutus-ledger.cabal b/plutus-ledger/plutus-ledger.cabal new file mode 100644 index 000000000..8870095bd --- /dev/null +++ b/plutus-ledger/plutus-ledger.cabal @@ -0,0 +1,184 @@ +cabal-version: 3.8 +name: plutus-ledger +version: 1.4.0.0 +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +maintainer: michael.peyton-jones@iohk.io +author: Michael Peyton Jones, Jann Mueller +synopsis: Wallet API +description: Plutus ledger library +category: Language +build-type: Simple +extra-doc-files: README.md + +common lang + default-language: Haskell2010 + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + MultiParamTypeClasses + ScopedTypeVariables + StandaloneDeriving + + -- See Plutus Tx readme for why we need the following flags: + -- -fobject-code -fno-ignore-interface-pragmas and -fno-omit-interface-pragmas + ghc-options: + -Wall -Wnoncanonical-monad-instances -Wno-unused-packages + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -fobject-code + -fno-ignore-interface-pragmas -fno-omit-interface-pragmas + -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt + PlutusTx.Plugin:defer-errors + + -- The limitation of plutus-tx-plugin + if (impl(ghc <9.6) || impl(ghc >=9.7)) + buildable: False + +library + import: lang + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Data.Aeson.Extras + Data.Time.Units.Extra + Ledger + Ledger.Address + Ledger.Address.Orphans + Ledger.AddressMap + Ledger.Blockchain + Ledger.Builtins.Orphans + Ledger.CardanoWallet + Ledger.Credential.Orphans + Ledger.Crypto + Ledger.Crypto.Orphans + Ledger.DCert.Orphans + Ledger.Index + Ledger.Index.Internal + Ledger.Orphans + Ledger.Scripts + Ledger.Scripts.Orphans + Ledger.Slot + Ledger.Test + Ledger.Tx + Ledger.Tx.CardanoAPI + Ledger.Tx.CardanoAPI.Internal + Ledger.Tx.Internal + Ledger.Tx.Orphans + Ledger.Tx.Orphans.V1 + Ledger.Tx.Orphans.V2 + Ledger.Typed.Scripts + Ledger.Typed.Scripts.Orphans + Ledger.Typed.Scripts.Validators + Ledger.Typed.Tx + Ledger.Typed.TypeUtils + Ledger.Value.CardanoAPI + Ledger.Value.Orphans + + -- The rest of the plutus-ledger-api modules are reexported from within + -- the Haskell modules and not in the current cabal file. + -- For example: PlutusLedgerApi.V1.Address is reexported by Ledger.Address + other-modules: Codec.CBOR.Extras + + -- The limitation of plutus-tx-plugin + if (impl(ghc <9.6) || impl(ghc >=9.7)) + buildable: False + + -------------------- + -- Local components + -------------------- + build-depends: plutus-script-utils ^>=1.4.0 + + -------------------------- + -- Other IOG dependencies + -------------------------- + build-depends: + , cardano-api:{cardano-api, internal} ^>=10.3 + , cardano-binary + , cardano-crypto + , cardano-ledger-alonzo + , cardano-ledger-byron + , cardano-ledger-conway + , cardano-ledger-core + , cardano-ledger-shelley + , data-default + , iohk-monitoring + , plutus-core >=1.0.0 + , plutus-ledger-api >=1.0.0 + , plutus-tx >=1.0.0 + , plutus-tx-plugin >=1.0.0 + + ------------------------ + -- Non-IOG dependencies + ------------------------ + -- TODO: remove the contractmodel dependency once the dependency on cardano-node + -- has been bumped to include the instance of Ord for AddressInEra + -- defined there. + build-depends: + , aeson + , base >=4.9 && <5 + , base16-bytestring + , bytestring + , cborg + , containers + , cryptonite >=0.25 + , flat + , hashable + , http-api-data + , lens + , memory + , newtype-generics + , prettyprinter + , scientific + , serialise + , servant + , text + , time-units + , vector + + ghc-options: -fprint-potential-instances + +test-suite plutus-ledger-test + import: lang + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + other-modules: Ledger.Tx.CardanoAPISpec + + -------------------- + -- Local components + -------------------- + build-depends: + , plutus-ledger ^>=1.4.0 + , plutus-script-utils ^>=1.4.0 + + -------------------------- + -- Other IOG dependencies + -------------------------- + build-depends: + , cardano-api:{cardano-api, gen} ^>=10.3 + , plutus-ledger-api >=1.0.0 + , plutus-tx >=1.0.0 + + ------------------------ + -- Non-IOG dependencies + ------------------------ + build-depends: + , aeson + , base >=4.9 && <5 + , bytestring + , hedgehog + , tasty + , tasty-hedgehog + , tasty-hunit diff --git a/plutus-ledger/src/Codec/CBOR/Extras.hs b/plutus-ledger/src/Codec/CBOR/Extras.hs new file mode 100644 index 000000000..07aa09525 --- /dev/null +++ b/plutus-ledger/src/Codec/CBOR/Extras.hs @@ -0,0 +1,22 @@ +-- | Copied from plutus-ledger-api because not exported +module Codec.CBOR.Extras where + +import Codec.CBOR.Decoding as CBOR +import Codec.Serialise (Serialise, decode, encode) +import Flat qualified +import Flat.Decoder qualified as Flat + +-- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance that +-- just encodes the flat-serialized value as a CBOR bytestring +newtype SerialiseViaFlat a = SerialiseViaFlat a + +instance (Flat.Flat a) => Serialise (SerialiseViaFlat a) where + encode (SerialiseViaFlat a) = encode $ Flat.flat a + decode = SerialiseViaFlat <$> (decodeViaFlat (Flat.decode)) + +decodeViaFlat :: Flat.Get a -> CBOR.Decoder s a +decodeViaFlat decoder = do + bs <- decodeBytes + case Flat.unflatWith decoder bs of + Left err -> fail (show err) + Right v -> pure v diff --git a/plutus-ledger/src/Data/Aeson/Extras.hs b/plutus-ledger/src/Data/Aeson/Extras.hs new file mode 100644 index 000000000..0c498ab21 --- /dev/null +++ b/plutus-ledger/src/Data/Aeson/Extras.hs @@ -0,0 +1,53 @@ +-- | Encoding and decoding of 'ByteString' and serialisable values +-- as base16 encoded JSON strings +module Data.Aeson.Extras + ( encodeByteString, + decodeByteString, + encodeSerialise, + decodeSerialise, + tryDecode, + JSONViaSerialise (..), + ) +where + +import Codec.CBOR.Write qualified as Write +import Codec.Serialise (Serialise, deserialiseOrFail, encode) +import Control.Monad ((>=>)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson +import Data.Bifunctor (first) +import Data.ByteString qualified as BSS +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Lazy qualified as BSL +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE + +encodeByteString :: BSS.ByteString -> Text.Text +encodeByteString = TE.decodeUtf8 . Base16.encode + +tryDecode :: Text.Text -> Either String BSS.ByteString +tryDecode = Base16.decode . TE.encodeUtf8 + +decodeByteString :: Aeson.Value -> Aeson.Parser BSS.ByteString +decodeByteString = Aeson.withText "ByteString" (either fail pure . tryDecode) + +encodeSerialise :: (Serialise a) => a -> Text.Text +encodeSerialise = encodeByteString . Write.toStrictByteString . encode + +decodeSerialise :: (Serialise a) => Aeson.Value -> Aeson.Parser a +decodeSerialise = decodeByteString >=> go + where + go bs = + case first show $ deserialiseOrFail $ BSL.fromStrict bs of + Left e -> fail e + Right v -> pure v + +-- | Newtype for deriving 'ToJSON' and 'FromJSON' for types that have a 'Serialise' +-- instance by just encoding the serialized bytes as a JSON string. +newtype JSONViaSerialise a = JSONViaSerialise a + +instance (Serialise a) => Aeson.ToJSON (JSONViaSerialise a) where + toJSON (JSONViaSerialise a) = Aeson.String $ encodeSerialise a + +instance (Serialise a) => Aeson.FromJSON (JSONViaSerialise a) where + parseJSON v = JSONViaSerialise <$> decodeSerialise v diff --git a/plutus-ledger/src/Data/Time/Units/Extra.hs b/plutus-ledger/src/Data/Time/Units/Extra.hs new file mode 100644 index 000000000..3062de335 --- /dev/null +++ b/plutus-ledger/src/Data/Time/Units/Extra.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Data.Time.Units.Extra where + +import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON, withScientific) +import Data.Scientific (toBoundedInteger) +import Data.Time.Units (Millisecond, Second) + +instance FromJSON Second where + parseJSON = + withScientific + "second" + ( \s -> + case toBoundedInteger s of + Nothing -> fail "Value must be an Integer." + Just i -> pure (fromIntegral (i :: Int)) + ) + +instance ToJSON Second where + toJSON = toJSON @Int . fromIntegral + +instance FromJSON Millisecond where + parseJSON = + withScientific + "millisecond" + ( \s -> + case toBoundedInteger s of + Nothing -> fail "Value must be an Integer." + Just i -> pure (fromIntegral (i :: Int)) + ) + +instance ToJSON Millisecond where + toJSON = toJSON @Int . fromIntegral diff --git a/plutus-ledger/src/Ledger.hs b/plutus-ledger/src/Ledger.hs new file mode 100644 index 000000000..07407489c --- /dev/null +++ b/plutus-ledger/src/Ledger.hs @@ -0,0 +1,24 @@ +module Ledger + ( module Export, + DCert, + NetworkId, + Credential, + StakingCredential, + ) +where + +import Cardano.Api (NetworkId) +import Ledger.Address as Export +import Ledger.Blockchain as Export +import Ledger.Crypto as Export +import Ledger.Index as Export hiding (singleton) +import Ledger.Orphans () +import Ledger.Scripts as Export +import Ledger.Slot as Export +import Ledger.Tx as Export +import Ledger.Value.CardanoAPI as Export hiding (singleton) +import PlutusLedgerApi.V1 (Credential, DCert) +import PlutusLedgerApi.V1.Contexts as Export hiding (TxId (..), TxOut (..), TxOutRef (..)) +import PlutusLedgerApi.V1.Credential (StakingCredential) +import PlutusLedgerApi.V1.Interval as Export +import PlutusLedgerApi.V1.Time as Export diff --git a/plutus-ledger/src/Ledger/Address.hs b/plutus-ledger/src/Ledger/Address.hs new file mode 100644 index 000000000..ba480b0d8 --- /dev/null +++ b/plutus-ledger/src/Ledger/Address.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ledger.Address + ( module Export, + CardanoAddress, + PaymentPrivateKey (..), + PaymentPubKey (..), + PaymentPubKeyHash (..), + StakePrivateKey (..), + StakePubKey (..), + StakePubKeyHash (..), + ToWitness (..), + toPlutusAddress, + toPlutusPubKeyHash, + cardanoAddressCredential, + cardanoPubKeyHash, + cardanoStakingCredential, + paymentPubKeyHash, + pubKeyHashAddress, + pubKeyAddress, + scriptValidatorHashAddress, + stakePubKeyHashCredential, + stakeValidatorHashCredential, + xprvToPaymentPubKey, + xprvToPaymentPubKeyHash, + xprvToStakingCredential, + xprvToStakePubKey, + xprvToStakePubKeyHash, + mkValidatorCardanoAddress, + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Chain.Common (addrToBase58) +import Cardano.Crypto.Wallet qualified as Crypto +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import Ledger.Address.Orphans as Export () +import Ledger.Crypto (PubKey (PubKey), PubKeyHash (PubKeyHash), pubKeyHash, toPublicKey) +import Ledger.Orphans () +import Ledger.Scripts + ( ScriptHash (..), + StakeValidatorHash (..), + ValidatorHash (..), + mkValidatorCardanoAddress, + ) +import PlutusLedgerApi.V1.Address as Export hiding (pubKeyHashAddress) +import PlutusLedgerApi.V1.Credential + ( Credential (PubKeyCredential, ScriptCredential), + StakingCredential (StakingHash), + ) +import PlutusTx qualified +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude qualified as PlutusTx +import Prettyprinter (Pretty) + +type CardanoAddress = C.AddressInEra C.ConwayEra + +instance ToJSONKey (C.AddressInEra C.ConwayEra) + +instance FromJSONKey (C.AddressInEra C.ConwayEra) + +cardanoAddressCredential :: C.AddressInEra era -> Credential +cardanoAddressCredential (C.AddressInEra C.ByronAddressInAnyEra (C.ByronAddress address)) = + PubKeyCredential $ + PubKeyHash $ + PlutusTx.toBuiltin $ + addrToBase58 address +cardanoAddressCredential (C.AddressInEra _ (C.ShelleyAddress _ paymentCredential _)) = + case C.fromShelleyPaymentCredential paymentCredential of + C.PaymentCredentialByKey paymentKeyHash -> + PubKeyCredential $ + PubKeyHash $ + PlutusTx.toBuiltin $ + C.serialiseToRawBytes paymentKeyHash + C.PaymentCredentialByScript scriptHash -> + ScriptCredential $ scriptToScriptHash scriptHash + +cardanoStakingCredential :: C.AddressInEra era -> Maybe StakingCredential +cardanoStakingCredential (C.AddressInEra C.ByronAddressInAnyEra _) = Nothing +cardanoStakingCredential (C.AddressInEra _ (C.ShelleyAddress _ _ stakeAddressReference)) = + case C.fromShelleyStakeReference stakeAddressReference of + C.NoStakeAddress -> Nothing + (C.StakeAddressByValue stakeCredential) -> + Just (StakingHash $ fromCardanoStakeCredential stakeCredential) + C.StakeAddressByPointer {} -> Nothing -- Not supported + where + fromCardanoStakeCredential :: C.StakeCredential -> Credential + fromCardanoStakeCredential (C.StakeCredentialByKey stakeKeyHash) = + PubKeyCredential $ + PubKeyHash $ + PlutusTx.toBuiltin $ + C.serialiseToRawBytes stakeKeyHash + fromCardanoStakeCredential (C.StakeCredentialByScript scriptHash) = ScriptCredential (scriptToScriptHash scriptHash) + +cardanoPubKeyHash :: C.AddressInEra era -> Maybe PubKeyHash +cardanoPubKeyHash addr = case cardanoAddressCredential addr of + PubKeyCredential x -> Just x + _ -> Nothing + +toPlutusAddress :: C.AddressInEra era -> Address +toPlutusAddress address = Address (cardanoAddressCredential address) (cardanoStakingCredential address) + +toPlutusPubKeyHash :: C.Hash C.PaymentKey -> PubKeyHash +toPlutusPubKeyHash paymentKeyHash = PubKeyHash $ PlutusTx.toBuiltin $ C.serialiseToRawBytes paymentKeyHash + +scriptToScriptHash :: C.ScriptHash -> ScriptHash +scriptToScriptHash = ScriptHash . PlutusTx.toBuiltin . C.serialiseToRawBytes + +newtype PaymentPrivateKey = PaymentPrivateKey {unPaymentPrivateKey :: Crypto.XPrv} + +newtype PaymentPubKey = PaymentPubKey {unPaymentPubKey :: PubKey} + deriving stock (Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + deriving newtype + (PlutusTx.Eq, PlutusTx.Ord, Serialise, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving (Show, Pretty) via PubKey + +makeLift ''PaymentPubKey + +xprvToPaymentPubKey :: Crypto.XPrv -> PaymentPubKey +xprvToPaymentPubKey = PaymentPubKey . toPublicKey + +newtype PaymentPubKeyHash = PaymentPubKeyHash {unPaymentPubKeyHash :: PubKeyHash} + deriving stock (Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + deriving newtype + ( PlutusTx.Eq, + PlutusTx.Ord, + Serialise, + Hashable, + PlutusTx.ToData, + PlutusTx.FromData, + PlutusTx.UnsafeFromData + ) + deriving (Show, Pretty) via PubKeyHash + +makeLift ''PaymentPubKeyHash + +xprvToPaymentPubKeyHash :: Crypto.XPrv -> PaymentPubKeyHash +xprvToPaymentPubKeyHash = PaymentPubKeyHash . pubKeyHash . toPublicKey + +newtype StakePrivateKey = StakePrivateKey {unStakePrivateKey :: Crypto.XPrv} + +newtype StakePubKey = StakePubKey {unStakePubKey :: PubKey} + deriving stock (Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + deriving newtype + (PlutusTx.Eq, PlutusTx.Ord, Serialise, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving (Show, Pretty) via PubKey + +makeLift ''StakePubKey + +xprvToStakePubKey :: Crypto.XPrv -> StakePubKey +xprvToStakePubKey = StakePubKey . toPublicKey + +newtype StakePubKeyHash = StakePubKeyHash {unStakePubKeyHash :: PubKeyHash} + deriving stock (Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + deriving newtype + ( PlutusTx.Eq, + PlutusTx.Ord, + Serialise, + Hashable, + PlutusTx.ToData, + PlutusTx.FromData, + PlutusTx.UnsafeFromData + ) + deriving (Show, Pretty) via PubKeyHash + +makeLift ''StakePubKeyHash + +xprvToStakePubKeyHash :: Crypto.XPrv -> StakePubKeyHash +xprvToStakePubKeyHash = StakePubKeyHash . pubKeyHash . toPublicKey + +xprvToStakingCredential :: Crypto.XPrv -> StakingCredential +xprvToStakingCredential = stakePubKeyHashCredential . xprvToStakePubKeyHash + +{-# INLINEABLE paymentPubKeyHash #-} +paymentPubKeyHash :: PaymentPubKey -> PaymentPubKeyHash +paymentPubKeyHash (PaymentPubKey pk) = PaymentPubKeyHash (pubKeyHash pk) + +{-# INLINEABLE pubKeyHashAddress #-} + +-- | The address that should be targeted by a transaction output locked by the +-- given public payment key (with its staking credentials). +pubKeyHashAddress :: PaymentPubKeyHash -> Maybe StakingCredential -> Address +pubKeyHashAddress (PaymentPubKeyHash pkh) = Address (PubKeyCredential pkh) + +{-# INLINEABLE pubKeyAddress #-} + +-- | The address that should be targeted by a transaction output locked by the given public key. +-- (with its staking credentials). +pubKeyAddress :: PaymentPubKey -> Maybe StakingCredential -> Address +pubKeyAddress (PaymentPubKey pk) = Address (PubKeyCredential (pubKeyHash pk)) + +{-# INLINEABLE scriptValidatorHashAddress #-} + +-- | The address that should be used by a transaction output locked by the given validator script +-- (with its staking credentials). +scriptValidatorHashAddress :: ValidatorHash -> Maybe StakingCredential -> Address +scriptValidatorHashAddress (ValidatorHash vh) = Address (ScriptCredential (ScriptHash vh)) + +{-# INLINEABLE stakePubKeyHashCredential #-} + +-- | Construct a `StakingCredential` from a public key hash. +stakePubKeyHashCredential :: StakePubKeyHash -> StakingCredential +stakePubKeyHashCredential = StakingHash . PubKeyCredential . unStakePubKeyHash + +{-# INLINEABLE stakeValidatorHashCredential #-} + +-- | Construct a `StakingCredential` from a validator script hash. +stakeValidatorHashCredential :: StakeValidatorHash -> StakingCredential +stakeValidatorHashCredential (StakeValidatorHash h) = StakingHash . ScriptCredential . ScriptHash $ h + +class ToWitness a where + toWitness :: a -> C.ShelleyWitnessSigningKey + +instance ToWitness PaymentPrivateKey where + toWitness (PaymentPrivateKey xprv) = C.WitnessPaymentExtendedKey (C.PaymentExtendedSigningKey xprv) + +instance ToWitness StakePrivateKey where + toWitness (StakePrivateKey xprv) = C.WitnessStakeExtendedKey (C.StakeExtendedSigningKey xprv) diff --git a/plutus-ledger/src/Ledger/Address/Orphans.hs b/plutus-ledger/src/Ledger/Address/Orphans.hs new file mode 100644 index 000000000..42001b166 --- /dev/null +++ b/plutus-ledger/src/Ledger/Address/Orphans.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Address.Orphans where + +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON, ToJSON) +import Ledger.Credential.Orphans () +import Ledger.Scripts.Orphans () +import PlutusLedgerApi.V1.Address + +deriving anyclass instance ToJSON Address + +deriving anyclass instance FromJSON Address + +deriving anyclass instance Serialise Address diff --git a/plutus-ledger/src/Ledger/AddressMap.hs b/plutus-ledger/src/Ledger/AddressMap.hs new file mode 100644 index 000000000..a280fe605 --- /dev/null +++ b/plutus-ledger/src/Ledger/AddressMap.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} + +-- | 'AddressMap's and functions for working on them. +-- +-- 'AddressMap's are used to represent the limited knowledge about the state of the ledger that +-- the wallet retains. Rather than keeping the entire ledger (which can be very large) the wallet +-- only tracks the UTxOs at particular addresses. +module Ledger.AddressMap + ( AddressMap (..), + UtxoMap, + addAddress, + addAddresses, + fundsAt, + values, + traverseWithKey, + singleton, + updateAddresses, + updateAllAddresses, + fromChain, + ) +where + +import Cardano.Api qualified as C +import Control.Lens + ( At (..), + Index, + IxValue, + Ixed (..), + Lens', + at, + lens, + non, + (&), + (.~), + (^.), + ) +import Control.Monad (join) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Foldable (fold) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import GHC.Generics (Generic) +import Ledger.Address (CardanoAddress) +import Ledger.Blockchain (Blockchain, OnChainTx, consumableInputs, outputsProduced, unOnChain) +import Ledger.Tx (CardanoTx, TxOut (..), txOutAddress, txOutValue) + +type UtxoMap = Map C.TxIn (CardanoTx, TxOut) + +-- | A map of 'Address'es and their unspent outputs. +newtype AddressMap = AddressMap {getAddressMap :: Map CardanoAddress UtxoMap} + deriving stock (Show, Eq, Generic) + deriving (ToJSON, FromJSON) + +-- | An address map with a single unspent transaction output. +singleton :: (CardanoAddress, C.TxIn, CardanoTx, TxOut) -> AddressMap +singleton (addr, ref, tx, ot) = AddressMap $ Map.singleton addr (Map.singleton ref (tx, ot)) + +instance Semigroup AddressMap where + (AddressMap l) <> (AddressMap r) = AddressMap (Map.unionWith add l r) + where + add = Map.union + +instance Monoid AddressMap where + mappend = (<>) + mempty = AddressMap Map.empty + +type instance Index AddressMap = CardanoAddress + +type instance IxValue AddressMap = Map C.TxIn (CardanoTx, TxOut) + +instance Ixed AddressMap where + ix adr f (AddressMap mp) = AddressMap <$> ix adr f mp + +instance At AddressMap where + at idx = lens g s + where + g (AddressMap mp) = mp ^. at idx + s (AddressMap mp) utxo = AddressMap $ mp & at idx .~ utxo + +-- | Get the funds available at a particular address. +fundsAt :: CardanoAddress -> Lens' AddressMap UtxoMap +fundsAt addr = at addr . non mempty + +-- | Add an address with no unspent outputs to a map. If the address already +-- exists, do nothing. +addAddress :: CardanoAddress -> AddressMap -> AddressMap +addAddress adr (AddressMap mp) = AddressMap $ Map.alter upd adr mp + where + upd :: Maybe UtxoMap -> Maybe UtxoMap + upd = maybe (Just Map.empty) Just + +-- | Add a list of 'Address'es with no unspent outputs to the map. +addAddresses :: [CardanoAddress] -> AddressMap -> AddressMap +addAddresses = flip (foldr addAddress) + +-- | The total value of unspent outputs (which the map knows about) at an address. +values :: AddressMap -> Map CardanoAddress C.Value +values = Map.map (fold . Map.map (txOutValue . snd)) . getAddressMap + +-- | Walk through the address map, applying an effectful function to each entry. +traverseWithKey :: + (Applicative f) => + (CardanoAddress -> Map C.TxIn (CardanoTx, TxOut) -> f (Map C.TxIn (CardanoTx, TxOut))) -> + AddressMap -> + f AddressMap +traverseWithKey f (AddressMap m) = AddressMap <$> Map.traverseWithKey f m + +-- | Create an 'AddressMap' with the unspent outputs of a single transaction. +fromTxOutputs :: OnChainTx -> AddressMap +fromTxOutputs tx = + AddressMap . Map.fromListWith Map.union . fmap mkUtxo . Map.toList . outputsProduced $ tx + where + mkUtxo (ref, txo) = (txOutAddress txo, Map.singleton ref (unOnChain tx, txo)) + +-- | Create a map of unspent transaction outputs to their addresses (the +-- "inverse" of an 'AddressMap', without the values) +knownAddresses :: AddressMap -> Map C.TxIn CardanoAddress +knownAddresses = Map.fromList . unRef . Map.toList . getAddressMap + where + unRef :: [(CardanoAddress, Map C.TxIn (CardanoTx, TxOut))] -> [(C.TxIn, CardanoAddress)] + unRef lst = do + (a, outRefs) <- lst + (rf, _) <- Map.toList outRefs + pure (rf, a) + +-- | Update an 'AddressMap' with the inputs and outputs of a new +-- transaction. @updateAddresses@ does /not/ add or remove any keys from the map. +updateAddresses :: OnChainTx -> AddressMap -> AddressMap +updateAddresses tx utxo = AddressMap $ Map.mapWithKey upd (getAddressMap utxo) + where + -- adds the newly produced outputs, and removes the consumed outputs, for + -- an address `adr` + upd :: CardanoAddress -> Map C.TxIn (CardanoTx, TxOut) -> Map C.TxIn (CardanoTx, TxOut) + upd adr mp = Map.union (producedAt adr) mp `Map.withoutKeys` consumedFrom adr + + -- The TxOutRefs produced by the transaction, for a given address + producedAt :: CardanoAddress -> Map C.TxIn (CardanoTx, TxOut) + producedAt adr = Map.findWithDefault mempty adr outputs + + -- The TxOutRefs consumed by the transaction, for a given address + consumedFrom :: CardanoAddress -> Set.Set C.TxIn + consumedFrom adr = Map.findWithDefault mempty adr consumedInputs + + AddressMap outputs = fromTxOutputs tx + + consumedInputs = inputs (knownAddresses utxo) tx + +-- | Update an 'AddressMap' with the inputs and outputs of a new +-- transaction, including all addresses in the transaction. +updateAllAddresses :: OnChainTx -> AddressMap -> AddressMap +-- updateAddresses handles getting rid of spent outputs, so all we have to do is add in the +-- new things. We can do this by just merging in `fromTxOutputs`, which will have many of the +-- things that are already there, but also the new things. +updateAllAddresses tx utxo = updateAddresses tx utxo <> fromTxOutputs tx + +-- | The inputs consumed by a transaction, indexed by address. +inputs :: + -- | A map of 'TxOutRef's to their 'Address'es + Map C.TxIn CardanoAddress -> + OnChainTx -> + Map CardanoAddress (Set.Set C.TxIn) +inputs addrs = + Map.fromListWith Set.union + . fmap (fmap Set.singleton . swap) + . mapMaybe (\a -> sequence (a, Map.lookup a addrs)) + . consumableInputs + +swap :: (a, b) -> (b, a) +swap (x, y) = (y, x) + +-- | The unspent transaction outputs of the ledger as a whole. +fromChain :: Blockchain -> AddressMap +fromChain = foldr updateAllAddresses mempty . join diff --git a/plutus-ledger/src/Ledger/Blockchain.hs b/plutus-ledger/src/Ledger/Blockchain.hs new file mode 100644 index 000000000..f39b71fb7 --- /dev/null +++ b/plutus-ledger/src/Ledger/Blockchain.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Ledger.Blockchain + ( OnChainTx (..), + Block, + BlockId (..), + Blockchain, + Context (..), + eitherTx, + unOnChain, + onChainTxIsValid, + consumableInputs, + outputsProduced, + ) +where + +import Cardano.Api qualified as C +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import Data.ByteString qualified as BS +import Data.Either (fromRight) +import Data.Map (Map) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8') +import GHC.Generics (Generic) +import Ledger.Index.Internal (OnChainTx (..), eitherTx, unOnChain) +import Ledger.Tx + ( TxOut, + getCardanoTxCollateralInputs, + getCardanoTxInputs, + getCardanoTxProducedOutputs, + getCardanoTxProducedReturnCollateral, + ) +import PlutusLedgerApi.V1.Scripts +import Prettyprinter (Pretty (..)) + +-- | Block identifier (usually a hash) +newtype BlockId = BlockId {getBlockId :: BS.ByteString} + deriving stock (Eq, Ord, Generic) + +instance Show BlockId where + show = Text.unpack . JSON.encodeByteString . getBlockId + +instance ToJSON BlockId where + toJSON = JSON.String . JSON.encodeByteString . getBlockId + +instance FromJSON BlockId where + parseJSON v = BlockId <$> JSON.decodeByteString v + +instance Pretty BlockId where + pretty (BlockId blockId) = + "BlockId " + <> pretty (fromRight (JSON.encodeByteString blockId) $ decodeUtf8' blockId) + +-- | A block on the blockchain. This is just a list of transactions +-- following on from the chain so far. +type Block = [OnChainTx] + +-- | A blockchain, which is just a list of blocks, starting with the newest. +type Blockchain = [Block] + +onChainTxIsValid :: OnChainTx -> Bool +onChainTxIsValid = eitherTx (const False) (const True) + +-- | Outputs consumed from the UTXO set by the 'OnChainTx' +consumableInputs :: OnChainTx -> [C.TxIn] +consumableInputs = eitherTx getCardanoTxCollateralInputs getCardanoTxInputs + +-- | Outputs added to the UTXO set by the 'OnChainTx' +outputsProduced :: OnChainTx -> Map C.TxIn TxOut +outputsProduced = eitherTx getCardanoTxProducedReturnCollateral getCardanoTxProducedOutputs diff --git a/plutus-ledger/src/Ledger/Builtins/Orphans.hs b/plutus-ledger/src/Ledger/Builtins/Orphans.hs new file mode 100644 index 000000000..20e5cde0c --- /dev/null +++ b/plutus-ledger/src/Ledger/Builtins/Orphans.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Builtins.Orphans where + +import Codec.Serialise (Serialise (decode, encode)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import PlutusCore.Data +import PlutusTx qualified +import PlutusTx.Prelude qualified as PlutusTx + +instance ToJSON PlutusTx.BuiltinByteString where + toJSON = JSON.String . JSON.encodeByteString . PlutusTx.fromBuiltin + +instance FromJSON PlutusTx.BuiltinByteString where + parseJSON v = PlutusTx.toBuiltin <$> JSON.decodeByteString v + +instance ToJSON PlutusTx.BuiltinData where + toJSON = toJSON . PlutusTx.builtinDataToData + +instance FromJSON PlutusTx.BuiltinData where + parseJSON = fmap PlutusTx.dataToBuiltinData . parseJSON + +instance Serialise PlutusTx.BuiltinData where + encode = encode . PlutusTx.builtinDataToData + decode = PlutusTx.dataToBuiltinData <$> decode + +deriving via (JSON.JSONViaSerialise Data) instance ToJSON Data + +deriving via (JSON.JSONViaSerialise Data) instance FromJSON Data diff --git a/plutus-ledger/src/Ledger/CardanoWallet.hs b/plutus-ledger/src/Ledger/CardanoWallet.hs new file mode 100644 index 000000000..df289a698 --- /dev/null +++ b/plutus-ledger/src/Ledger/CardanoWallet.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{- Cardano wallet implementation for the emulator. +-} +module Ledger.CardanoWallet + ( MockWallet (..), + + -- * Enumerating wallets + WalletNumber (..), + fromWalletNumber, + toWalletNumber, + knownMockWallets, + knownMockWallet, + fromSeed, + fromSeed', + + -- ** Keys + mockWalletAddress, + paymentPrivateKey, + paymentPubKeyHash, + paymentPubKey, + stakingCredential, + stakePubKeyHash, + stakePubKey, + stakePrivateKey, + knownAddresses, + knownPaymentKeys, + knownPaymentPublicKeys, + knownPaymentPrivateKeys, + ) +where + +import Cardano.Crypto.Wallet qualified as Crypto +import Codec.Serialise (serialise) +import Crypto.Hash qualified as Crypto +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson.Extras (encodeByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Coerce (coerce) +import Data.Either (fromRight) +import Data.Hashable (Hashable (..)) +import Data.List (findIndex) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Ledger.Address + ( CardanoAddress, + PaymentPrivateKey (PaymentPrivateKey, unPaymentPrivateKey), + PaymentPubKey (PaymentPubKey, unPaymentPubKey), + PaymentPubKeyHash (PaymentPubKeyHash, unPaymentPubKeyHash), + StakePrivateKey (StakePrivateKey, unStakePrivateKey), + StakePubKey (StakePubKey, unStakePubKey), + StakePubKeyHash (StakePubKeyHash, unStakePubKeyHash), + stakePubKeyHashCredential, + ) +import Ledger.Crypto (PubKey (..)) +import Ledger.Crypto qualified as Crypto +import Ledger.Test (testnet) +import Ledger.Tx.CardanoAPI.Internal qualified as Tx +import PlutusLedgerApi.V1 + ( Address (Address), + Credential (PubKeyCredential), + StakingCredential (StakingHash), + ) +import PlutusLedgerApi.V1.Bytes (LedgerBytes (getLedgerBytes)) +import Servant.API (FromHttpApiData, ToHttpApiData) + +newtype MockPrivateKey = MockPrivateKey {unMockPrivateKey :: Crypto.XPrv} + +instance Show MockPrivateKey where + show = T.unpack . encodeByteString . Crypto.unXPrv . unMockPrivateKey + +instance Eq MockPrivateKey where + (MockPrivateKey l) == (MockPrivateKey r) = Crypto.unXPrv l == Crypto.unXPrv r + +instance Ord MockPrivateKey where + compare (MockPrivateKey l) (MockPrivateKey r) = compare (Crypto.unXPrv l) (Crypto.unXPrv r) + +instance Hashable MockPrivateKey where + hashWithSalt i = hashWithSalt i . Crypto.unXPrv . unMockPrivateKey + +-- | Emulated wallet with a key and a passphrase +data MockWallet = MockWallet + { mwWalletId :: Crypto.Digest Crypto.Blake2b_160, + mwPaymentKey :: MockPrivateKey, + mwStakeKey :: Maybe MockPrivateKey, + mwPrintAs :: Maybe String + } + deriving (Show) + +-- | Wrapper for config files and APIs +newtype WalletNumber = WalletNumber {getWallet :: Integer} + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (ToHttpApiData, FromHttpApiData, Num, Enum, Real) + deriving anyclass (FromJSON, ToJSON) + +-- Workaround for warning "Call of toInteger :: Integer -> Integer can probably be omitted" GHC issue #21679 +instance Integral WalletNumber where + quotRem = + coerce @(Integer -> Integer -> (Integer, Integer)) + @(WalletNumber -> WalletNumber -> (WalletNumber, WalletNumber)) + quotRem + toInteger = coerce + +fromWalletNumber :: WalletNumber -> MockWallet +fromWalletNumber (WalletNumber i) = (fromSeed' (BSL.toStrict $ serialise i)) {mwPrintAs = Just (show i)} + +fromSeed :: BS.ByteString -> Crypto.Passphrase -> MockWallet +fromSeed bs passPhrase = fromSeedInternal (flip Crypto.generateFromSeed passPhrase) bs + +fromSeed' :: BS.ByteString -> MockWallet +fromSeed' = fromSeedInternal Crypto.generateFromSeed' + +fromSeedInternal :: (BS.ByteString -> Crypto.XPrv) -> BS.ByteString -> MockWallet +fromSeedInternal seedGen bs = MockWallet {mwWalletId, mwPaymentKey, mwStakeKey, mwPrintAs = Nothing} + where + missing = max 0 (32 - BS.length bs) + bs' = bs <> BS.replicate missing 0 + k = seedGen bs' + mwWalletId = + fromMaybe (error "Ledger.CardanoWallet.fromSeed: digestFromByteString") $ + Crypto.digestFromByteString $ + Crypto.hashWith Crypto.Blake2b_160 $ + getLedgerBytes $ + getPubKey $ + Crypto.toPublicKey k + mwPaymentKey = MockPrivateKey k + mwStakeKey = Nothing + +toWalletNumber :: MockWallet -> WalletNumber +toWalletNumber MockWallet {mwWalletId = w} = + maybe + (error "Ledger.CardanoWallet.toWalletNumber: not a known wallet") + (WalletNumber . toInteger . succ) + $ findIndex ((==) w . mwWalletId) knownMockWallets + +-- | The wallets used in mockchain simulations by default. There are +-- ten wallets by default. +knownMockWallets :: [MockWallet] +knownMockWallets = fromWalletNumber . WalletNumber <$> [1 .. 10] + +-- | Get a known wallet from an @Integer@ indexed from 1 to 10. +knownMockWallet :: Integer -> MockWallet +knownMockWallet = (knownMockWallets !!) . pred . fromInteger + +-- | A mock cardano address for the testnet network. +mockWalletAddress :: MockWallet -> CardanoAddress +mockWalletAddress = + fromRight (error "mock wallet is invalid") + . Tx.toCardanoAddressInEra testnet + . plutusAddress + where + plutusAddress mw = + Address + (PubKeyCredential $ unPaymentPubKeyHash $ paymentPubKeyHash mw) + (StakingHash . PubKeyCredential . unStakePubKeyHash <$> stakePubKeyHash mw) + +-- | Mock wallet's private key +paymentPrivateKey :: MockWallet -> PaymentPrivateKey +paymentPrivateKey = PaymentPrivateKey . unMockPrivateKey . mwPaymentKey + +-- | The mock wallet's public key hash +paymentPubKeyHash :: MockWallet -> PaymentPubKeyHash +paymentPubKeyHash = PaymentPubKeyHash . Crypto.pubKeyHash . unPaymentPubKey . paymentPubKey + +-- | The mock wallet's payment public key +paymentPubKey :: MockWallet -> PaymentPubKey +paymentPubKey = PaymentPubKey . Crypto.toPublicKey . unMockPrivateKey . mwPaymentKey + +-- | The mock wallet's stake public key hash +stakePubKeyHash :: MockWallet -> Maybe StakePubKeyHash +stakePubKeyHash w = StakePubKeyHash . Crypto.pubKeyHash . unStakePubKey <$> stakePubKey w + +-- | The mock wallet's stake public key +stakePubKey :: MockWallet -> Maybe StakePubKey +stakePubKey w = StakePubKey . Crypto.toPublicKey . unStakePrivateKey <$> stakePrivateKey w + +-- | The mock wallet's stake private key +stakePrivateKey :: MockWallet -> Maybe StakePrivateKey +stakePrivateKey w = StakePrivateKey . unMockPrivateKey <$> mwStakeKey w + +-- | The mock wallet's staking credentials +stakingCredential :: MockWallet -> Maybe StakingCredential +stakingCredential = fmap stakePubKeyHashCredential . stakePubKeyHash + +knownPaymentPublicKeys :: [PaymentPubKey] +knownPaymentPublicKeys = + PaymentPubKey . Crypto.toPublicKey . unPaymentPrivateKey <$> knownPaymentPrivateKeys + +knownPaymentKeys :: Map.Map PaymentPubKey PaymentPrivateKey +knownPaymentKeys = + Map.fromList $ + map + (\k -> (PaymentPubKey $ Crypto.toPublicKey $ unPaymentPrivateKey k, k)) + knownPaymentPrivateKeys + +knownPaymentPrivateKeys :: [PaymentPrivateKey] +knownPaymentPrivateKeys = paymentPrivateKey <$> knownMockWallets + +knownAddresses :: [CardanoAddress] +knownAddresses = mockWalletAddress <$> knownMockWallets diff --git a/plutus-ledger/src/Ledger/Credential/Orphans.hs b/plutus-ledger/src/Ledger/Credential/Orphans.hs new file mode 100644 index 000000000..cf9031359 --- /dev/null +++ b/plutus-ledger/src/Ledger/Credential/Orphans.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Credential.Orphans where + +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON, ToJSON) +import Data.Hashable (Hashable) +import Ledger.Crypto.Orphans () +import Ledger.Scripts.Orphans () +import PlutusLedgerApi.V1.Credential + +deriving anyclass instance ToJSON Credential + +deriving anyclass instance FromJSON Credential + +deriving anyclass instance Hashable Credential + +deriving anyclass instance Serialise Credential + +deriving anyclass instance ToJSON StakingCredential + +deriving anyclass instance FromJSON StakingCredential + +deriving anyclass instance Hashable StakingCredential + +deriving anyclass instance Serialise StakingCredential diff --git a/plutus-ledger/src/Ledger/Crypto.hs b/plutus-ledger/src/Ledger/Crypto.hs new file mode 100644 index 000000000..0bc31ce19 --- /dev/null +++ b/plutus-ledger/src/Ledger/Crypto.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Crypto + ( module Export, + PubKey (..), + PrivateKey (..), + Signature (..), + Passphrase (..), + pubKeyHash, + signedBy, + sign, + signTx, + generateFromSeed, + toPublicKey, + xPubToPublicKey, + + -- * Signing and generation with no passphrase + sign', + signTx', + generateFromSeed', + ) +where + +import Cardano.Crypto.Wallet qualified as Crypto +import Codec.Serialise.Class (Serialise) +import Control.Newtype.Generics (Newtype) +import Crypto.Hash qualified as Crypto +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.:)) +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import Data.ByteArray qualified as BA +import Data.ByteString qualified as BS +import Data.Hashable (Hashable) +import Data.String +import GHC.Generics (Generic) +import Ledger.Tx.Orphans.V1 () +import PlutusLedgerApi.V1 (LedgerBytes (LedgerBytes), TxId (TxId), fromBuiltin, toBuiltin) +import PlutusLedgerApi.V1.Bytes qualified as KB +import PlutusLedgerApi.V1.Crypto as Export +import PlutusTx qualified as PlutusTx +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude qualified as PlutusTx +import Prettyprinter (Pretty) + +-- | Passphrase newtype to mark intent +newtype Passphrase = Passphrase {unPassphrase :: BS.ByteString} + deriving newtype (IsString) + +instance Show Passphrase where + show _ = "" + +-- | A message with a cryptographic signature. +newtype Signature = Signature {getSignature :: PlutusTx.BuiltinByteString} + deriving stock (Eq, Ord, Generic) + deriving newtype + (PlutusTx.Eq, PlutusTx.Ord, Serialise, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving (Show, Pretty) via LedgerBytes + +makeLift ''Signature + +instance ToJSON Signature where + toJSON signature = + JSON.object + [ ( "getSignature", + JSON.String + . JSON.encodeByteString + . PlutusTx.fromBuiltin + . getSignature + $ signature + ) + ] + +instance FromJSON Signature where + parseJSON = + JSON.withObject "Signature" $ \object -> do + raw <- object .: "getSignature" + bytes <- JSON.decodeByteString raw + pure . Signature $ PlutusTx.toBuiltin $ bytes + +newtype PubKey = PubKey {getPubKey :: LedgerBytes} + deriving stock (Eq, Ord, Generic) + deriving anyclass (Newtype, ToJSON, FromJSON) + deriving newtype + (PlutusTx.Eq, PlutusTx.Ord, Serialise, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving (IsString) via LedgerBytes + deriving (Show, Pretty) via LedgerBytes + +makeLift ''PubKey + +instance ToJSONKey PubKey where + toJSONKey = JSON.ToJSONKeyValue (JSON.genericToJSON JSON.defaultOptions) JSON.toEncoding + +instance FromJSONKey PubKey where + fromJSONKey = JSON.FromJSONKeyValue (JSON.genericParseJSON JSON.defaultOptions) + +-- | A cryptographic private key. +newtype PrivateKey = PrivateKey {getPrivateKey :: LedgerBytes} + deriving stock (Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON, Newtype, ToJSONKey, FromJSONKey) + deriving newtype + (PlutusTx.Eq, PlutusTx.Ord, Serialise, PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving (Show, Pretty) via LedgerBytes + deriving (Hashable) via PlutusTx.BuiltinByteString + +makeLift ''PrivateKey + +-- | Compute the hash of a public key. +pubKeyHash :: PubKey -> PubKeyHash +pubKeyHash (PubKey (LedgerBytes bs)) = + PubKeyHash $ + toBuiltin $ + BA.convert @_ @BS.ByteString $ + Crypto.hashWith Crypto.Blake2b_224 (fromBuiltin bs) + +-- | Check whether the given 'Signature' was signed by the private key corresponding to the given public key. +signedBy :: (BA.ByteArrayAccess a) => Signature -> PubKey -> a -> Bool +signedBy (Signature s) (PubKey k) payload = + let xpub = Crypto.XPub (KB.bytes k) (Crypto.ChainCode "" {- value is ignored -}) + xsig = either error id $ Crypto.xsignature (PlutusTx.fromBuiltin s) + in Crypto.verify xpub payload xsig + +-- | Sign the hash of a transaction using a private key and passphrase. +signTx :: TxId -> Crypto.XPrv -> Passphrase -> Signature +signTx (TxId txId) = sign txId + +-- | Sign the hash of a transaction using a private key that has no passphrase. +signTx' :: TxId -> Crypto.XPrv -> Signature +signTx' txId xprv = signTx txId xprv noPassphrase + +-- | Sign a message using a private key and passphrase. +sign :: (BA.ByteArrayAccess a) => a -> Crypto.XPrv -> Passphrase -> Signature +sign msg privKey (Passphrase passPhrase) = Signature . toBuiltin . Crypto.unXSignature $ Crypto.sign passPhrase privKey msg + +-- | Sign a message using a private key with no passphrase. +sign' :: (BA.ByteArrayAccess a) => a -> Crypto.XPrv -> Signature +sign' msg privKey = sign msg privKey noPassphrase + +-- | Generate a private key from a seed phrase and passphrase +generateFromSeed :: BS.ByteString -> Passphrase -> Crypto.XPrv +generateFromSeed seed (Passphrase passPhrase) = Crypto.generate seed passPhrase + +-- | Generate a private key from a seed phrase without a passphrase. +generateFromSeed' :: BS.ByteString -> Crypto.XPrv +generateFromSeed' seed = generateFromSeed seed noPassphrase + +noPassphrase :: Passphrase +noPassphrase = Passphrase "" + +xPubToPublicKey :: Crypto.XPub -> PubKey +xPubToPublicKey = PubKey . KB.fromBytes . Crypto.xpubPublicKey + +toPublicKey :: Crypto.XPrv -> PubKey +toPublicKey = xPubToPublicKey . Crypto.toXPub diff --git a/plutus-ledger/src/Ledger/Crypto/Orphans.hs b/plutus-ledger/src/Ledger/Crypto/Orphans.hs new file mode 100644 index 000000000..eb67591bd --- /dev/null +++ b/plutus-ledger/src/Ledger/Crypto/Orphans.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Crypto.Orphans where + +import Codec.Serialise (Serialise) +import Control.Newtype.Generics (Newtype) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Hashable (Hashable) +import Ledger.Builtins.Orphans () +import PlutusLedgerApi.V1.Crypto + +deriving anyclass instance ToJSON PubKeyHash + +deriving anyclass instance FromJSON PubKeyHash + +deriving anyclass instance FromJSONKey PubKeyHash + +deriving anyclass instance ToJSONKey PubKeyHash + +deriving anyclass instance Newtype PubKeyHash + +deriving newtype instance Serialise PubKeyHash + +deriving newtype instance Hashable PubKeyHash diff --git a/plutus-ledger/src/Ledger/DCert/Orphans.hs b/plutus-ledger/src/Ledger/DCert/Orphans.hs new file mode 100644 index 000000000..723556214 --- /dev/null +++ b/plutus-ledger/src/Ledger/DCert/Orphans.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.DCert.Orphans where + +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON, ToJSON) +import Ledger.Credential.Orphans () +import Ledger.Crypto.Orphans () +import PlutusLedgerApi.V1.DCert (DCert) + +deriving anyclass instance ToJSON DCert + +deriving anyclass instance FromJSON DCert + +deriving anyclass instance Serialise DCert diff --git a/plutus-ledger/src/Ledger/Index.hs b/plutus-ledger/src/Ledger/Index.hs new file mode 100644 index 000000000..aeb081226 --- /dev/null +++ b/plutus-ledger/src/Ledger/Index.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | An index of unspent transaction outputs, and some functions for validating +-- transactions using the index. +module Ledger.Index + ( -- * Types for transaction validation based on UTXO index + UtxoIndex, + insert, + insertCollateral, + insertBlock, + initialise, + singleton, + lookup, + lookupUTxO, + getCollateral, + ValidationError (..), + _TxOutRefNotFound, + _ScriptFailure, + _CardanoLedgerValidationError, + ValidationResult (..), + _Success, + _FailPhase1, + _FailPhase2, + cardanoTxFromValidationResult, + toOnChain, + getEvaluationLogs, + ValidationSuccess, + ValidationErrorInPhase, + ValidationPhase (..), + RedeemerReport, + maxFee, + adjustTxOut, + minAdaTxOut, + minAdaTxOutEstimated, + minLovelaceTxOutEstimated, + maxMinAdaTxOut, + createGenesisTransaction, + genesisTxIn, + PV1.ExBudget (..), + PV1.ExCPU (..), + PV1.ExMemory (..), + PV1.SatInt, + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C.Api +import Cardano.Ledger.Coin (Coin (Coin)) +import Cardano.Ledger.Conway qualified as Conway +import Cardano.Ledger.Core (PParams, getMinCoinTxOut) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Shelley.API qualified as C.Ledger +import Control.Lens (alaf, (&), (.~), (<&>)) +import Data.Foldable (foldl') +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (Ap (..)) +import Data.Set qualified as Set +import Ledger.Address (CardanoAddress) +import Ledger.Blockchain +import Ledger.Index.Internal +import Ledger.Orphans () +import Ledger.Tx + ( CardanoTx (..), + TxOut (..), + getCardanoTxCollateralInputs, + getCardanoTxFee, + getCardanoTxProducedOutputs, + getCardanoTxProducedReturnCollateral, + getCardanoTxSpentOutputs, + getCardanoTxTotalCollateral, + outValue, + txOutValue, + ) +import Ledger.Tx.CardanoAPI (fromPlutusTxOut, toCardanoTxOutValue) +import Ledger.Tx.Internal qualified as Tx +import Ledger.Value.CardanoAPI (Value, lovelaceToValue) +import Plutus.Script.Utils.Ada (Ada) +import Plutus.Script.Utils.Ada qualified as Ada +import PlutusLedgerApi.V1 qualified as PV1 +import PlutusTx.Lattice ((\/)) +import Prelude hiding (lookup) + +-- | Create an index of all UTxOs on the chain. +initialise :: Blockchain -> UtxoIndex +initialise = (`insertBlock` mempty) . concat + +-- | Create an index with a single UTxO. +singleton :: C.TxIn -> C.TxOut C.CtxUTxO C.ConwayEra -> UtxoIndex +singleton txIn txOut = C.UTxO $ Map.singleton txIn txOut + +-- | Update the index for the addition of a transaction. +insert :: CardanoTx -> UtxoIndex -> UtxoIndex +insert tx (C.UTxO unspent) = + C.UTxO $ + (unspent `Map.withoutKeys` getCardanoTxSpentOutputs tx) + `Map.union` (Tx.toCtxUTxOTxOut <$> getCardanoTxProducedOutputs tx) + +-- | Update the index for the addition of only the collateral inputs of a failed transaction. +insertCollateral :: CardanoTx -> UtxoIndex -> UtxoIndex +insertCollateral tx (C.UTxO unspent) = + C.UTxO $ + (unspent `Map.withoutKeys` (Set.fromList $ getCardanoTxCollateralInputs tx)) + `Map.union` (Tx.toCtxUTxOTxOut <$> getCardanoTxProducedReturnCollateral tx) + +-- | Update the index for the addition of a block. +insertBlock :: Block -> UtxoIndex -> UtxoIndex +insertBlock blck i = foldl' (flip (eitherTx insertCollateral insert)) i blck + +-- | Find an unspent transaction output by the 'TxIn' that spends it. +lookup :: C.TxIn -> UtxoIndex -> Maybe TxOut +lookup i index = case lookupUTxO i index of + Just (C.TxOut aie tov tod rs) -> + let tod' = case tod of + C.TxOutDatumNone -> C.TxOutDatumNone + C.TxOutDatumHash era scriptDataHash -> C.TxOutDatumHash era scriptDataHash + C.TxOutDatumInline era scriptData -> C.TxOutDatumInline era scriptData + in Just $ TxOut (C.TxOut aie tov tod' rs) + Nothing -> Nothing + +-- | Find an unspent transaction output (using the Ledger type) by the 'TxIn' that spends it. +lookupUTxO :: C.TxIn -> UtxoIndex -> Maybe (C.TxOut C.CtxUTxO C.ConwayEra) +lookupUTxO i index = Map.lookup i $ C.unUTxO index + +getCollateral :: UtxoIndex -> CardanoTx -> C.Value +getCollateral idx tx = case getCardanoTxTotalCollateral tx of + Just v -> lovelaceToValue v + Nothing -> + fromMaybe (lovelaceToValue $ getCardanoTxFee tx) $ + alaf Ap foldMap (fmap txOutValue . (`lookup` idx)) (getCardanoTxCollateralInputs tx) + +-- | Adjust a single transaction output so it contains at least the minimum amount of Ada +-- and return the adjustment (if any) and the updated TxOut. +adjustTxOut :: PParams (Conway.ConwayEra StandardCrypto) -> TxOut -> ([Coin], Tx.TxOut) +adjustTxOut params txOut = do + -- Increasing the ada amount can also increase the size in bytes, so start with a rough estimated amount of ada + let withMinAdaValue = toCardanoTxOutValue $ txOutValue txOut \/ lovelaceToValue (minAdaTxOut params txOut) + let txOutEstimate = txOut & outValue .~ withMinAdaValue + minAdaTxOutEstimated' = minAdaTxOut params txOutEstimate + missingLovelace = minAdaTxOutEstimated' - C.selectLovelace (txOutValue txOut) + if missingLovelace > 0 + then + let adjustedLovelace = toCardanoTxOutValue $ txOutValue txOut <> lovelaceToValue missingLovelace + in ([missingLovelace], txOut & outValue .~ adjustedLovelace) + else ([], txOut) + +-- | Exact computation of the mimimum Ada required for a given TxOut. +-- TODO: Should be moved to cardano-api-extended once created +minAdaTxOut :: PParams (Conway.ConwayEra StandardCrypto) -> TxOut -> Coin +minAdaTxOut params txOut = + let toLovelace = Coin . C.Ledger.unCoin + initialValue = txOutValue txOut + firstEstimate = toLovelace . getMinCoinTxOut params $ fromPlutusTxOut txOut -- if the estimate is above the initialValue, we run minAdaAgain, just to be sure that the + -- new amount didn't change the TxOut size and requires more ada. + in if firstEstimate > C.selectLovelace initialValue + then + minAdaTxOut params . flip (outValue .~) txOut $ + toCardanoTxOutValue $ + lovelaceToValue firstEstimate \/ initialValue + else firstEstimate + +{-# INLINEABLE minAdaTxOutEstimated #-} + +-- | Provide a reasonable estimate of the mimimum of Ada required for a TxOut. +-- +-- An exact estimate of the the mimimum of Ada in a TxOut is determined by two things: +-- - the `PParams`, more precisely its 'coinPerUTxOWord' parameter. +-- - the size of the 'TxOut'. +-- In many situations though, we need to determine a plausible value for the minimum of Ada needed for a TxOut +-- without knowing much of the 'TxOut'. +-- This function provides a value big enough to balance UTxOs without +-- a large inlined data (larger than a hash) nor a complex val with a lot of minted values. +-- It's superior to the lowest minimum needed for an UTxO, as the lowest value require no datum. +-- An estimate of the minimum required Ada for each tx output. +minAdaTxOutEstimated :: Ada +minAdaTxOutEstimated = Ada.lovelaceOf minTxOut + +minLovelaceTxOutEstimated :: Coin +minLovelaceTxOutEstimated = Coin minTxOut + +{-# INLINEABLE minTxOut #-} +minTxOut :: Integer +minTxOut = 2_000_000 + +{-# INLINEABLE maxMinAdaTxOut #-} +{- +maxMinAdaTxOut = maxTxOutSize * coinsPerUTxOWord +coinsPerUTxOWord = 34_482 +maxTxOutSize = utxoEntrySizeWithoutVal + maxValSizeInWords + dataHashSize +utxoEntrySizeWithoutVal = 27 +maxValSizeInWords = 500 +dataHashSize = 10 + +These values are partly protocol parameters-based, but since this is used in on-chain code +we want a constant to reduce code size. +-} +maxMinAdaTxOut :: Ada +maxMinAdaTxOut = Ada.lovelaceOf 18_516_834 + +-- | TODO Should be calculated based on the maximum script size permitted on +-- the Cardano blockchain. +maxFee :: Ada +maxFee = Ada.lovelaceOf 1_000_000 + +-- | cardano-ledger validation rules require the presence of inputs and +-- we have to provide a stub TxIn for the genesis transaction. +genesisTxIn :: C.TxIn +genesisTxIn = C.TxIn "01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53" (C.TxIx 40_214) + +createGenesisTransaction :: Map.Map CardanoAddress Value -> CardanoTx +createGenesisTransaction vals = + let txBodyContent = + Tx.emptyTxBodyContent + { C.txIns = [(genesisTxIn, C.BuildTxWith (C.KeyWitness C.KeyWitnessForSpending))], + C.txOuts = + Map.toList vals <&> \(changeAddr, v) -> + C.TxOut changeAddr (toCardanoTxOutValue v) C.TxOutDatumNone C.Api.ReferenceScriptNone + } + txBody = + either (error . ("createGenesisTransaction: Can't create TxBody: " <>) . show) id $ + C.createTransactionBody C.shelleyBasedEra txBodyContent + in CardanoEmulatorEraTx $ C.Tx txBody [] diff --git a/plutus-ledger/src/Ledger/Index/Internal.hs b/plutus-ledger/src/Ledger/Index/Internal.hs new file mode 100644 index 000000000..0e47ae346 --- /dev/null +++ b/plutus-ledger/src/Ledger/Index/Internal.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Index.Internal where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Binary qualified as CBOR +import Cardano.Ledger.Alonzo.Scripts (AsIx, ExUnits, PlutusPurpose) +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (AlonzoTx), IsValid (IsValid)) +import Cardano.Ledger.Core (Tx) +import Cardano.Ledger.Shelley.API (Validated, extractTx) +import Codec.Serialise (Serialise (..)) +import Control.Lens (makePrisms) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Map qualified as Map +import Data.Text (Text) +import GHC.Generics (Generic) +import Ledger.Orphans () +import Ledger.Tx.CardanoAPI.Internal (CardanoTx, EmulatorEra, pattern CardanoEmulatorEraTx) +import PlutusLedgerApi.V1.Scripts qualified as Scripts +import Prettyprinter (Pretty (..), hang, vsep, (<+>)) +import Prettyprinter.Extras (PrettyShow (..)) +import Prettyprinter.Util (reflow) +import Prelude hiding (lookup) + +-- | A transaction on the blockchain. +-- Invalid transactions are still put on the chain to be able to collect fees. +newtype OnChainTx = OnChainTx {getOnChainTx :: Validated (Tx EmulatorEra)} + deriving (Eq, Show, Generic) + +instance Serialise OnChainTx where + encode = CBOR.toCBOR . extractTx . getOnChainTx -- For blockID + decode = fail "Not allowed to use `decode` on `OnChainTx`" -- Unused + +eitherTx :: (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r +eitherTx ifInvalid ifValid (extractTx . getOnChainTx -> tx@(AlonzoTx _ _ (IsValid isValid) _)) = + let ctx = CardanoEmulatorEraTx (C.ShelleyTx C.ShelleyBasedEraConway tx) + in if isValid then ifValid ctx else ifInvalid ctx + +unOnChain :: OnChainTx -> CardanoTx +unOnChain = eitherTx id id + +-- | The UTxOs of a blockchain indexed by their references. +type UtxoIndex = C.UTxO C.ConwayEra + +deriving newtype instance Semigroup (C.UTxO era) + +deriving newtype instance Monoid (C.UTxO era) + +-- | A reason why a transaction is invalid. +data ValidationError + = -- | The transaction output consumed by a transaction input could not be found (either because it was already spent, or because + -- there was no transaction with the given hash on the blockchain). + TxOutRefNotFound C.TxIn + | -- | For pay-to-script outputs: evaluation of the validator script failed. + ScriptFailure Scripts.ScriptError + | -- | An error from Cardano.Ledger validation + CardanoLedgerValidationError Text + | -- | Balancing failed, it needed more than the maximum number of collateral inputs + MaxCollateralInputsExceeded + deriving (Eq, Show, Generic) + +makePrisms ''ValidationError + +instance FromJSON ValidationError + +instance ToJSON ValidationError + +deriving via (PrettyShow ValidationError) instance Pretty ValidationError + +data ValidationPhase = Phase1 | Phase2 deriving (Eq, Show, Generic, FromJSON, ToJSON) + +deriving via (PrettyShow ValidationPhase) instance Pretty ValidationPhase + +type ValidationErrorInPhase = (ValidationPhase, ValidationError) + +type ValidationSuccess = (RedeemerReport, Validated (Tx EmulatorEra)) + +type RedeemerReport = Map.Map (PlutusPurpose AsIx EmulatorEra) ([Text], ExUnits) + +data ValidationResult + = -- | A transaction failed to validate in phase 1. + FailPhase1 !CardanoTx !ValidationError + | -- | A transaction failed to validate in phase 2. The @Value@ indicates the amount of collateral stored in the transaction. + FailPhase2 !OnChainTx !ValidationError !C.Value + | Success !OnChainTx !RedeemerReport + deriving stock (Eq, Show, Generic) + +makePrisms ''ValidationResult + +data ValidationResultSimple + = ValidationFailPhase1 !CardanoTx !ValidationError + | ValidationFailPhase2 !CardanoTx !ValidationError !C.Value + | ValidationSuccess !CardanoTx + deriving stock (Generic) + deriving anyclass (ToJSON, FromJSON) + +toValidationResultSimple :: ValidationResult -> ValidationResultSimple +toValidationResultSimple (FailPhase1 tx err) = ValidationFailPhase1 tx err +toValidationResultSimple (FailPhase2 vtx err val) = ValidationFailPhase2 (unOnChain vtx) err val +toValidationResultSimple (Success vtx _) = ValidationSuccess (unOnChain vtx) + +instance ToJSON ValidationResult where + toJSON = toJSON . toValidationResultSimple + +instance FromJSON ValidationResult where + parseJSON = mempty -- Always fail, this instance isn't really used, but required by pab's logging framework. + +instance Pretty ValidationResult where + pretty res = + hang 2 $ + vsep $ + case res of + FailPhase1 _ err -> "Validation failed in phase 1:" <+> pretty err + FailPhase2 _ err _ -> "Validation failed in phase 2:" <+> pretty err + Success {} -> "Validation success" + : fmap reflow (getEvaluationLogs res) + +cardanoTxFromValidationResult :: ValidationResult -> CardanoTx +cardanoTxFromValidationResult (FailPhase1 tx _) = tx +cardanoTxFromValidationResult (FailPhase2 vtx _ _) = unOnChain vtx +cardanoTxFromValidationResult (Success vtx _) = unOnChain vtx + +toOnChain :: ValidationResult -> Maybe OnChainTx +toOnChain (Success tx _) = Just tx +toOnChain (FailPhase2 tx _ _) = Just tx +toOnChain _ = Nothing + +-- | Get logs from evaluating plutus scripts. +getEvaluationLogs :: ValidationResult -> [Text] +getEvaluationLogs = \case + Success _ r -> concatMap (fst . snd) $ Map.toList r + FailPhase1 _ err -> logs err + FailPhase2 _ err _ -> logs err + where + logs = \case + ScriptFailure (Scripts.EvaluationError msgs _) -> msgs + _ -> [] diff --git a/plutus-ledger/src/Ledger/Orphans.hs b/plutus-ledger/src/Ledger/Orphans.hs new file mode 100644 index 000000000..2be3d3df0 --- /dev/null +++ b/plutus-ledger/src/Ledger/Orphans.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ledger.Orphans where + +import Cardano.Api qualified as C +import Codec.Serialise.Class (Serialise (..)) +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import Data.Aeson.Types qualified as JSON +import Data.Bifunctor (bimap) +import Data.ByteArray qualified as BA +import Data.Data (Data) +import Data.Hashable (Hashable) +import Data.Scientific (floatingOrInteger, scientific) +import Data.Text qualified as Text +import GHC.Generics (Generic) +import Ledger.Crypto (PrivateKey (PrivateKey, getPrivateKey)) +import PlutusLedgerApi.V1 (LedgerBytes, POSIXTime (POSIXTime), TxId (TxId), fromBytes) +import PlutusLedgerApi.V1.Bytes (bytes) +import PlutusLedgerApi.V1.Scripts (ScriptError) +import Web.HttpApiData (FromHttpApiData (parseUrlPiece), ToHttpApiData (toUrlPiece)) + +-- TODO: remove this dependency here once the instance of Ord for AddressInEra +-- can be obtained from upstream and removed from quickcheck-contractmodel. +-- import Test.QuickCheck.ContractModel.Internal.Common () + +instance ToHttpApiData PrivateKey where + toUrlPiece = toUrlPiece . getPrivateKey + +instance FromHttpApiData PrivateKey where + parseUrlPiece a = PrivateKey <$> parseUrlPiece a + +instance ToHttpApiData LedgerBytes where + toUrlPiece = JSON.encodeByteString . bytes + +instance FromHttpApiData LedgerBytes where + parseUrlPiece = bimap Text.pack fromBytes . JSON.tryDecode + +-- | ByteArrayAccess instance for signing support +instance BA.ByteArrayAccess TxId where + length (TxId bis) = BA.length bis + withByteArray (TxId bis) = BA.withByteArray bis + +deriving instance Data C.NetworkMagic + +deriving instance Data C.NetworkId + +deriving instance Generic C.NetworkId + +instance Serialise (C.AddressInEra C.ConwayEra) where + encode = encode . C.serialiseToRawBytes + decode = do + bs <- decode + either + (fail . show) + pure + $ C.deserialiseFromRawBytes (C.AsAddressInEra C.AsConwayEra) bs + +deriving instance Generic C.PolicyId + +deriving instance Generic C.Quantity + +-- 'POSIXTime' instances + +-- | Custom `FromJSON` instance which allows to parse a JSON number to a +-- 'POSIXTime' value. The parsed JSON value MUST be an 'Integer' or else the +-- parsing fails. +instance JSON.FromJSON POSIXTime where + parseJSON v@(JSON.Number n) = + either + (\_ -> JSON.prependFailure "parsing POSIXTime failed, " (JSON.typeMismatch "Integer" v)) + (return . POSIXTime) + (floatingOrInteger n :: Either Double Integer) + parseJSON invalid = + JSON.prependFailure "parsing POSIXTime failed, " (JSON.typeMismatch "Number" invalid) + +-- | Custom 'ToJSON' instance which allows to simply convert a 'POSIXTime' +-- value to a JSON number. +instance JSON.ToJSON POSIXTime where + toJSON (POSIXTime n) = JSON.Number $ scientific n 0 + +deriving newtype instance Serialise POSIXTime + +deriving newtype instance Hashable POSIXTime + +deriving anyclass instance JSON.ToJSON ScriptError + +deriving anyclass instance JSON.FromJSON ScriptError diff --git a/plutus-ledger/src/Ledger/Scripts.hs b/plutus-ledger/src/Ledger/Scripts.hs new file mode 100644 index 000000000..dcd143f3f --- /dev/null +++ b/plutus-ledger/src/Ledger/Scripts.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} + +module Ledger.Scripts + ( module Export, + unitDatum, + unitRedeemer, + examplePlutusScriptAlwaysSucceeds, + examplePlutusScriptAlwaysFails, + examplePlutusScriptAlwaysSucceedsHash, + examplePlutusScriptAlwaysFailsHash, + WitCtx (..), + ) +where + +import Cardano.Api + ( PlutusScriptVersion (PlutusScriptV1), + Script (PlutusScript), + WitCtx (..), + examplePlutusScriptAlwaysFails, + examplePlutusScriptAlwaysSucceeds, + hashScript, + serialiseToRawBytes, + ) +import Ledger.Scripts.Orphans () +import Plutus.Script.Utils.Scripts as Export +import PlutusLedgerApi.V1.Scripts as Export +import PlutusTx (toBuiltinData) +import PlutusTx.Builtins (BuiltinByteString, toBuiltin) + +examplePlutusScriptAlwaysSucceedsHash :: WitCtx ctx -> BuiltinByteString +examplePlutusScriptAlwaysSucceedsHash = + toBuiltin + . serialiseToRawBytes + . hashScript + . PlutusScript PlutusScriptV1 + . examplePlutusScriptAlwaysSucceeds + +examplePlutusScriptAlwaysFailsHash :: WitCtx ctx -> BuiltinByteString +examplePlutusScriptAlwaysFailsHash = + toBuiltin + . serialiseToRawBytes + . hashScript + . PlutusScript PlutusScriptV1 + . examplePlutusScriptAlwaysFails + +-- | @()@ as a datum. +unitDatum :: Datum +unitDatum = Datum $ toBuiltinData () + +-- | @()@ as a redeemer. +unitRedeemer :: Redeemer +unitRedeemer = Redeemer $ toBuiltinData () diff --git a/plutus-ledger/src/Ledger/Scripts/Orphans.hs b/plutus-ledger/src/Ledger/Scripts/Orphans.hs new file mode 100644 index 000000000..abc86a121 --- /dev/null +++ b/plutus-ledger/src/Ledger/Scripts/Orphans.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Scripts.Orphans where + +import Codec.CBOR.Extras (SerialiseViaFlat (..)) +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON (parseJSON), FromJSONKey, ToJSON (toJSON), ToJSONKey) +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import Data.Hashable (Hashable) +import Ledger.Builtins.Orphans () +import Plutus.Script.Utils.Scripts +import PlutusLedgerApi.V1.Scripts + +{- Note [JSON instances for Script] +The JSON instances for Script are partially hand-written rather than going via the Serialise +instance directly. The reason for this is to *avoid* the size checks that are in place in the +Serialise instance. These are only useful for deserialisation checks on-chain, whereas the +JSON instances are used for e.g. transmitting validation events, which often include scripts +with the data arguments applied (which can be very big!). +-} + +instance ToJSON Script where + -- See note [JSON instances for Script] + toJSON (Script p) = JSON.String $ JSON.encodeSerialise (SerialiseViaFlat p) + +instance FromJSON Script where + -- See note [JSON instances for Script] + parseJSON v = do + (SerialiseViaFlat p) <- JSON.decodeSerialise v + return $ Script p + +deriving anyclass instance ToJSON DatumHash + +deriving anyclass instance FromJSON DatumHash + +deriving anyclass instance ToJSONKey DatumHash + +deriving anyclass instance FromJSONKey DatumHash + +deriving newtype instance Hashable DatumHash + +deriving newtype instance Serialise DatumHash + +deriving anyclass instance ToJSON RedeemerHash + +deriving anyclass instance FromJSON RedeemerHash + +deriving anyclass instance ToJSONKey RedeemerHash + +deriving anyclass instance FromJSONKey RedeemerHash + +deriving newtype instance Hashable RedeemerHash + +deriving newtype instance Serialise RedeemerHash + +deriving anyclass instance ToJSON MintingPolicyHash + +deriving anyclass instance FromJSON MintingPolicyHash + +deriving anyclass instance ToJSONKey MintingPolicyHash + +deriving anyclass instance FromJSONKey MintingPolicyHash + +deriving newtype instance Hashable MintingPolicyHash + +deriving newtype instance Serialise MintingPolicyHash + +deriving anyclass instance ToJSON StakeValidatorHash + +deriving anyclass instance FromJSON StakeValidatorHash + +deriving anyclass instance ToJSONKey StakeValidatorHash + +deriving anyclass instance FromJSONKey StakeValidatorHash + +deriving newtype instance Hashable StakeValidatorHash + +deriving newtype instance Serialise StakeValidatorHash + +deriving anyclass instance ToJSON ScriptHash + +deriving anyclass instance FromJSON ScriptHash + +deriving anyclass instance ToJSONKey ScriptHash + +deriving anyclass instance FromJSONKey ScriptHash + +deriving newtype instance Hashable ScriptHash + +deriving newtype instance Serialise ScriptHash + +deriving anyclass instance ToJSON ValidatorHash + +deriving anyclass instance FromJSON ValidatorHash + +deriving anyclass instance ToJSONKey ValidatorHash + +deriving anyclass instance FromJSONKey ValidatorHash + +deriving newtype instance Hashable ValidatorHash + +deriving newtype instance Serialise ValidatorHash + +deriving newtype instance ToJSON Context + +deriving newtype instance FromJSON Context + +deriving anyclass instance ToJSON StakeValidator + +deriving anyclass instance FromJSON StakeValidator + +deriving anyclass instance ToJSON MintingPolicy + +deriving anyclass instance FromJSON MintingPolicy + +deriving anyclass instance ToJSON Validator + +deriving anyclass instance FromJSON Validator + +deriving anyclass instance ToJSON Redeemer + +deriving anyclass instance FromJSON Redeemer + +deriving anyclass instance ToJSON Datum + +deriving anyclass instance FromJSON Datum diff --git a/plutus-ledger/src/Ledger/Slot.hs b/plutus-ledger/src/Ledger/Slot.hs new file mode 100644 index 000000000..7cfac2aa4 --- /dev/null +++ b/plutus-ledger/src/Ledger/Slot.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- Otherwise we get a complaint about the 'fromIntegral' call in the generated instance of 'Integral' for 'Ada' +{-# OPTIONS_GHC -Wno-identities #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Slots and slot ranges. +module Ledger.Slot + ( Slot (..), + SlotRange, + width, + ) +where + +import Codec.Serialise.Class (Serialise) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Data (Data) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Interval +import PlutusTx qualified +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude +import Prettyprinter (Pretty (pretty), (<+>)) +import Prelude qualified as Haskell + +{- HLINT ignore "Redundant if" -} + +-- | The slot number. This is a good proxy for time, since on the Cardano blockchain +-- slots pass at a constant rate. +newtype Slot = Slot {getSlot :: Integer} + deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Generic, Data) + deriving anyclass (FromJSON, FromJSONKey, ToJSON, ToJSONKey) + deriving newtype + ( AdditiveSemigroup, + AdditiveMonoid, + AdditiveGroup, + Eq, + Ord, + Enum, + PlutusTx.ToData, + PlutusTx.FromData, + PlutusTx.UnsafeFromData + ) + deriving newtype (Haskell.Num, Haskell.Enum, Haskell.Real, Haskell.Integral, Serialise) + +makeLift ''Slot + +instance Pretty Slot where + pretty (Slot i) = "Slot" <+> pretty i + +-- | An 'Interval' of 'Slot's. +type SlotRange = Interval Slot + +{-# INLINEABLE width #-} + +-- | Number of 'Slot's covered by the interval, if finite. @width (from x) == Nothing@. +width :: SlotRange -> Maybe Integer +width (Interval (LowerBound (Finite (Slot s1)) in1) (UpperBound (Finite (Slot s2)) in2)) = + let lowestValue = if in1 then s1 else s1 + 1 + highestValue = if in2 then s2 else s2 - 1 + in if lowestValue <= highestValue + then -- +1 avoids fencepost error: width of [2,4] is 3. + Just $ (highestValue - lowestValue) + 1 + else -- low > high, i.e. empty interval + Nothing +-- Infinity is involved! +width _ = Nothing + +deriving anyclass instance (Serialise a) => Serialise (Interval a) + +deriving anyclass instance (ToJSON a) => ToJSON (Interval a) + +deriving anyclass instance (FromJSON a) => FromJSON (Interval a) + +deriving anyclass instance (Serialise a) => Serialise (LowerBound a) + +deriving anyclass instance (ToJSON a) => ToJSON (LowerBound a) + +deriving anyclass instance (FromJSON a) => FromJSON (LowerBound a) + +deriving anyclass instance (Serialise a) => Serialise (UpperBound a) + +deriving anyclass instance (ToJSON a) => ToJSON (UpperBound a) + +deriving anyclass instance (FromJSON a) => FromJSON (UpperBound a) + +deriving anyclass instance (Serialise a) => Serialise (Extended a) + +deriving anyclass instance (ToJSON a) => ToJSON (Extended a) + +deriving anyclass instance (FromJSON a) => FromJSON (Extended a) diff --git a/plutus-ledger/src/Ledger/Test.hs b/plutus-ledger/src/Ledger/Test.hs new file mode 100644 index 000000000..b3ddfcc94 --- /dev/null +++ b/plutus-ledger/src/Ledger/Test.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Ledger.Test where + +import Cardano.Api qualified as C +import Ledger qualified +import Ledger.Typed.Scripts qualified as Scripts +import Ledger.Value.CardanoAPI (policyId) +import Plutus.Script.Utils.Typed as PSU +import Plutus.Script.Utils.V1.Address qualified as PV1 +import Plutus.Script.Utils.V1.Scripts qualified as PV1 +import Plutus.Script.Utils.V2.Address qualified as PV2 +import Plutus.Script.Utils.V2.Scripts qualified as PV2 +import Plutus.Script.Utils.Value (mpsSymbol) +import PlutusLedgerApi.V1 (Address) +import PlutusLedgerApi.V1.Value qualified as Value +import PlutusLedgerApi.V2 qualified as PV2 +import PlutusLedgerApi.V3 qualified as PV3 +import PlutusTx qualified +import PlutusTx.Builtins.Internal qualified as PlutusTx +import Prelude hiding (not) + +someCode :: + PlutusTx.CompiledCode + (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit) +someCode = $$(PlutusTx.compile [||\_ _ _ -> PlutusTx.unitval||]) + +someValidator :: Scripts.Validator +someValidator = Ledger.mkValidatorScript someCode + +someTypedValidator :: Scripts.TypedValidator Any +someTypedValidator = Scripts.unsafeMkTypedValidator (Versioned someValidator PlutusV1) + +someValidatorHash :: PV1.ValidatorHash +someValidatorHash = PV1.validatorHash someValidator + +someCardanoAddress :: C.NetworkId -> Ledger.CardanoAddress +someCardanoAddress = flip PV1.mkValidatorCardanoAddress someValidator + +someAddress :: Address +someAddress = Ledger.scriptValidatorHashAddress someValidatorHash Nothing + +someValidatorV2 :: Scripts.Validator +someValidatorV2 = Ledger.mkValidatorScript someCode + +someTypedValidatorV2 :: Scripts.TypedValidator Any +someTypedValidatorV2 = Scripts.unsafeMkTypedValidator (Versioned someValidator PlutusV2) + +someValidatorHashV2 :: PV2.ValidatorHash +someValidatorHashV2 = PV2.validatorHash someValidatorV2 + +someCardanoAddressV2 :: C.NetworkId -> Ledger.CardanoAddress +someCardanoAddressV2 = flip PV2.mkValidatorCardanoAddress someValidatorV2 + +someAddressV2 :: Address +someAddressV2 = Ledger.scriptValidatorHashAddress someValidatorHashV2 Nothing + +{-# INLINEABLE mkPolicy #-} +mkPolicy :: () -> Ledger.ScriptContext -> Bool +mkPolicy _ _ = True + +{-# INLINEABLE mkPolicyV2 #-} +mkPolicyV2 :: () -> PV2.ScriptContext -> Bool +mkPolicyV2 _ _ = True + +{-# INLINEABLE mkPolicyV3 #-} +mkPolicyV3 :: () -> PV3.ScriptContext -> Bool +mkPolicyV3 _ _ = True + +coinMintingPolicy :: Language -> Versioned Ledger.MintingPolicy +coinMintingPolicy lang = case lang of + PlutusV1 -> Versioned coinMintingPolicyV1 lang + PlutusV2 -> Versioned coinMintingPolicyV2 lang + PlutusV3 -> Versioned coinMintingPolicyV3 lang + +coinMintingPolicyV1 :: Ledger.MintingPolicy +coinMintingPolicyV1 = + Ledger.mkMintingPolicyScript + $$(PlutusTx.compile [||PSU.mkUntypedMintingPolicy mkPolicy||]) + +coinMintingPolicyV2 :: Ledger.MintingPolicy +coinMintingPolicyV2 = + Ledger.mkMintingPolicyScript + $$(PlutusTx.compile [||PSU.mkUntypedMintingPolicy mkPolicyV2||]) + +coinMintingPolicyV3 :: Ledger.MintingPolicy +coinMintingPolicyV3 = + Ledger.mkMintingPolicyScript + $$(PlutusTx.compile [||PSU.mkUntypedMintingPolicy mkPolicyV3||]) + +coinMintingPolicyHash :: Language -> Ledger.MintingPolicyHash +coinMintingPolicyHash = Ledger.mintingPolicyHash . coinMintingPolicy + +coinMintingPolicyCurrencySymbol :: Language -> Value.CurrencySymbol +coinMintingPolicyCurrencySymbol = mpsSymbol . coinMintingPolicyHash + +someToken :: Language -> Value.Value +someToken lang = Value.singleton (coinMintingPolicyCurrencySymbol lang) "someToken" 1 + +asRedeemer :: (PlutusTx.ToData a) => a -> Ledger.Redeemer +asRedeemer a = Ledger.Redeemer $ PlutusTx.dataToBuiltinData $ PlutusTx.toData a + +asDatum :: (PlutusTx.ToData a) => a -> Ledger.Datum +asDatum a = Ledger.Datum $ PlutusTx.dataToBuiltinData $ PlutusTx.toData a + +coinMintingPolicyId :: Language -> C.PolicyId +coinMintingPolicyId = policyId . coinMintingPolicy + +testNetworkMagic :: C.NetworkMagic +testNetworkMagic = C.NetworkMagic 1097911063 + +testnet :: C.NetworkId +testnet = C.Testnet testNetworkMagic diff --git a/plutus-ledger/src/Ledger/Tx.hs b/plutus-ledger/src/Ledger/Tx.hs new file mode 100644 index 000000000..9501fcd75 --- /dev/null +++ b/plutus-ledger/src/Ledger/Tx.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Tx + ( module Export, + C.TxId (..), + C.TxIn (..), + C.TxIx (..), + + -- * DecoratedTxOut + DecoratedTxOut (..), + toTxOut, + toTxInfoTxOut, + toDecoratedTxOut, + + -- ** Lenses and Prisms + decoratedTxOutPubKeyHash, + decoratedTxOutAddress, + decoratedTxOutDatum, + decoratedTxOutValue, + decoratedTxOutPubKeyDatum, + decoratedTxOutScriptDatum, + decoratedTxOutStakingCredential, + decoratedTxOutReferenceScript, + decoratedTxOutValidatorHash, + decoratedTxOutValidator, + _PublicKeyDecoratedTxOut, + _ScriptDecoratedTxOut, + _decoratedTxOutAddress, + + -- ** smart Constructors + mkDecoratedTxOut, + mkPubkeyDecoratedTxOut, + mkScriptDecoratedTxOut, + + -- * DatumFromQuery + DatumFromQuery (..), + datumInDatumFromQuery, + + -- * Transactions + getCardanoTxId, + getCardanoTxInputs, + getCardanoTxCollateralInputs, + getCardanoTxOutRefs, + getCardanoTxOutputs, + getCardanoTxRedeemers, + getCardanoTxSpentOutputs, + getCardanoTxProducedOutputs, + getCardanoTxReturnCollateral, + getCardanoTxProducedReturnCollateral, + getCardanoTxTotalCollateral, + getCardanoTxFee, + getCardanoTxMint, + getCardanoTxValidityRange, + getCardanoTxData, + CardanoTx (.., CardanoEmulatorEraTx), + ToCardanoError (..), + addCardanoTxWitness, + + -- * TxBodyContent functions + getTxBodyContentInputs, + getTxBodyContentCollateralInputs, + getTxBodyContentReturnCollateral, + getTxBodyContentMint, + getTxBodyContentCerts, + txBodyContentIns, + txBodyContentCollateralIns, + txBodyContentOuts, + + -- * Utility + decoratedTxOutPlutusValue, + fromDecoratedIndex, + ) +where + +-- for re-export + +import Cardano.Api (TxBodyContent (txValidityUpperBound)) +import Cardano.Api qualified as C +import Cardano.Api.ReexposeLedger qualified as C.Ledger +import Cardano.Api.Shelley qualified as C.Api +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) +import Cardano.Ledger.Alonzo.TxWits (txwitsVKey) +import Cardano.Ledger.Coin (Coin) +import Codec.Serialise (Serialise) +import Control.Lens + ( Getter, + Lens', + Traversal', + lens, + makeLenses, + makePrisms, + to, + view, + views, + (^.), + (^?), + ) +import Data.Aeson (FromJSON, ToJSON) +import Data.Coerce (coerce) +import Data.List (genericLength) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Tuple (swap) +import GHC.Generics (Generic) +import Ledger.Address (Address, CardanoAddress, cardanoAddressCredential, cardanoStakingCredential) +import Ledger.Index.Internal (UtxoIndex) +import Ledger.Orphans () +import Ledger.Slot (SlotRange) +import Ledger.Tx.CardanoAPI + ( CardanoTx (CardanoTx), + ToCardanoError (..), + pattern CardanoEmulatorEraTx, + ) +import Ledger.Tx.CardanoAPI qualified as CardanoAPI +import Ledger.Tx.Internal as Export +import Plutus.Script.Utils.Scripts (Script, Validator, ValidatorHash (..), scriptHash) +import PlutusLedgerApi.V1 qualified as V1 hiding (TxOutRef (..)) +import PlutusLedgerApi.V1.Tx as Export hiding + ( TxId (..), + TxOut (..), + TxOutRef (..), + outAddress, + outValue, + txOutDatum, + txOutPubKey, + ) +import PlutusLedgerApi.V1.Value (Value) +import PlutusLedgerApi.V2 qualified as V2 +import PlutusLedgerApi.V2.Tx qualified as V2.Tx hiding (TxId (..)) +import Prettyprinter (Pretty (pretty), colon, hang, nest, viaShow, vsep, (<+>)) + +-- | A datum in a transaction output that comes from a chain index query. +data DatumFromQuery + = DatumUnknown + | DatumInline V2.Datum + | DatumInBody V2.Datum + deriving (Show, Eq, Serialise, Generic, ToJSON, FromJSON) + +makePrisms ''DatumFromQuery + +datumInDatumFromQuery :: Traversal' DatumFromQuery V2.Datum +datumInDatumFromQuery _ DatumUnknown = pure DatumUnknown +datumInDatumFromQuery f (DatumInline d) = DatumInline <$> f d +datumInDatumFromQuery f (DatumInBody d) = DatumInBody <$> f d + +-- | Offchain view of a transaction output. +data DecoratedTxOut + = PublicKeyDecoratedTxOut + { -- | The pubKey hash that protects the transaction address + _decoratedTxOutPubKeyHash :: V1.PubKeyHash, + -- | The staking credential of the transaction address, if any + _decoratedTxOutStakingCredential :: Maybe V1.StakingCredential, + -- | Value of the transaction output. + _decoratedTxOutValue :: C.Value, + -- | Optional datum (inline datum or datum in transaction body) attached to the transaction output. + _decoratedTxOutPubKeyDatum :: Maybe (V2.DatumHash, DatumFromQuery), + -- | Value of the transaction output. + _decoratedTxOutReferenceScript :: Maybe (Versioned Script) + } + | ScriptDecoratedTxOut + { -- | The hash of the script that protects the transaction address + _decoratedTxOutValidatorHash :: ValidatorHash, + -- | The staking credential of the transaction address, if any + _decoratedTxOutStakingCredential :: Maybe V1.StakingCredential, + -- | Value of the transaction output. + _decoratedTxOutValue :: C.Value, + -- | Datum attached to the transaction output, either in full (inline datum or datum in transaction body) or as a + -- hash reference. A transaction output protected by a Plutus script + -- is guardateed to have an associated datum. + _decoratedTxOutScriptDatum :: (V2.DatumHash, DatumFromQuery), + -- The reference script is, in genereal, unrelated to the validator + -- script althought it could also be the same. + _decoratedTxOutReferenceScript :: Maybe (Versioned Script), + -- | Full version of the validator protecting the transaction output + _decoratedTxOutValidator :: Maybe (Versioned Validator) + } + deriving (Show, Eq, Serialise, Generic, ToJSON, FromJSON) + +makeLenses ''DecoratedTxOut +makePrisms ''DecoratedTxOut + +mkDecoratedTxOut :: + CardanoAddress -> + C.Value -> + Maybe (V2.DatumHash, DatumFromQuery) -> + Maybe (Versioned Script) -> + Maybe DecoratedTxOut +mkDecoratedTxOut a v md rs = + let sc = cardanoStakingCredential a + in case cardanoAddressCredential a of + (V2.PubKeyCredential c) -> Just (PublicKeyDecoratedTxOut c sc v md rs) + (V2.ScriptCredential (V2.ScriptHash c)) -> (\dt -> ScriptDecoratedTxOut (ValidatorHash c) sc v dt rs Nothing) <$> md + +mkPubkeyDecoratedTxOut :: + CardanoAddress -> + C.Value -> + Maybe (V2.DatumHash, DatumFromQuery) -> + Maybe (Versioned Script) -> + Maybe DecoratedTxOut +mkPubkeyDecoratedTxOut a v dat rs = + let sc = cardanoStakingCredential a + in case cardanoAddressCredential a of + (V2.PubKeyCredential c) -> Just $ PublicKeyDecoratedTxOut c sc v dat rs + _ -> Nothing + +mkScriptDecoratedTxOut :: + CardanoAddress -> + C.Value -> + (V2.DatumHash, DatumFromQuery) -> + Maybe (Versioned Script) -> + Maybe (Versioned Validator) -> + Maybe DecoratedTxOut +mkScriptDecoratedTxOut a v dat rs val = + let sc = cardanoStakingCredential a + in case cardanoAddressCredential a of + (V2.ScriptCredential (V2.ScriptHash c)) -> pure $ ScriptDecoratedTxOut (ValidatorHash c) sc v dat rs val + _ -> Nothing + +_decoratedTxOutAddress :: DecoratedTxOut -> Address +_decoratedTxOutAddress PublicKeyDecoratedTxOut {_decoratedTxOutPubKeyHash, _decoratedTxOutStakingCredential} = + V1.Address (V1.PubKeyCredential _decoratedTxOutPubKeyHash) _decoratedTxOutStakingCredential +_decoratedTxOutAddress ScriptDecoratedTxOut {_decoratedTxOutValidatorHash, _decoratedTxOutStakingCredential} = + V1.Address + (V1.ScriptCredential (V2.ScriptHash (getValidatorHash _decoratedTxOutValidatorHash))) + _decoratedTxOutStakingCredential + +decoratedTxOutAddress :: Getter DecoratedTxOut Address +decoratedTxOutAddress = to _decoratedTxOutAddress + +decoratedTxOutDatum :: Traversal' DecoratedTxOut (V2.DatumHash, DatumFromQuery) +decoratedTxOutDatum f p@(PublicKeyDecoratedTxOut pkh sc v dat rs) = + maybe (pure p) (fmap (\dat' -> PublicKeyDecoratedTxOut pkh sc v (Just dat') rs) . f) dat +decoratedTxOutDatum f (ScriptDecoratedTxOut vh sc v dat rs val) = + (\dat' -> ScriptDecoratedTxOut vh sc v dat' rs val) <$> f dat + +toDecoratedTxOut :: TxOut -> Maybe DecoratedTxOut +toDecoratedTxOut (TxOut (C.TxOut addr' val dt rs)) = + mkDecoratedTxOut + addr' + (C.txOutValueToValue val) + (toDecoratedDatum dt) + (CardanoAPI.fromCardanoReferenceScript rs) + where + toDecoratedDatum :: C.TxOutDatum C.CtxTx C.ConwayEra -> Maybe (V2.DatumHash, DatumFromQuery) + toDecoratedDatum C.TxOutDatumNone = + Nothing + toDecoratedDatum (C.TxOutDatumHash _ h) = + Just (V2.DatumHash $ V2.toBuiltin (C.serialiseToRawBytes h), DatumUnknown) + toDecoratedDatum (C.TxOutSupplementalDatum _ d) = + Just + ( V2.DatumHash $ V2.toBuiltin (C.serialiseToRawBytes (C.hashScriptDataBytes d)), + DatumInBody $ V2.Datum $ CardanoAPI.fromCardanoScriptData d + ) + toDecoratedDatum (C.TxOutDatumInline _ d) = + Just + ( V2.DatumHash $ V2.toBuiltin (C.serialiseToRawBytes (C.hashScriptDataBytes d)), + DatumInline $ V2.Datum $ CardanoAPI.fromCardanoScriptData d + ) + +toTxOut :: C.NetworkId -> DecoratedTxOut -> Either ToCardanoError TxOut +toTxOut networkId p = + TxOut + <$> ( C.TxOut + <$> CardanoAPI.toCardanoAddressInEra networkId (p ^. decoratedTxOutAddress) + <*> pure (CardanoAPI.toCardanoTxOutValue (p ^. decoratedTxOutValue)) + <*> (toTxOutDatum $ p ^? decoratedTxOutDatum) + <*> pure (CardanoAPI.toCardanoReferenceScript (p ^. decoratedTxOutReferenceScript)) + ) + +toTxOutDatum :: + Maybe (V2.DatumHash, DatumFromQuery) -> Either ToCardanoError (C.TxOutDatum C.CtxTx C.ConwayEra) +toTxOutDatum = CardanoAPI.toCardanoTxOutDatum . toPlutusOutputDatum + +-- | Converts a transaction output from the chain index to the plutus-ledger-api +-- transaction output. +-- +-- Note that 'DecoratedTxOut' supports features such inline datums and +-- reference scripts which are not supported by V1 TxOut. Converting from +-- 'DecoratedTxOut' to 'TxOut' and back is therefore lossy. +toTxInfoTxOut :: DecoratedTxOut -> V2.Tx.TxOut +toTxInfoTxOut p = + V2.Tx.TxOut + (p ^. decoratedTxOutAddress) + (CardanoAPI.fromCardanoValue $ p ^. decoratedTxOutValue) + (toPlutusOutputDatum $ p ^? decoratedTxOutDatum) + (views decoratedTxOutReferenceScript (fmap scriptHash) p) + +toPlutusOutputDatum :: Maybe (V2.DatumHash, DatumFromQuery) -> V2.Tx.OutputDatum +toPlutusOutputDatum Nothing = V2.Tx.NoOutputDatum +toPlutusOutputDatum (Just (_, DatumInline d)) = V2.Tx.OutputDatum d +toPlutusOutputDatum (Just (dh, _)) = V2.Tx.OutputDatumHash dh + +fromDecoratedIndex :: + C.Api.NetworkId -> Map TxOutRef DecoratedTxOut -> Either ToCardanoError UtxoIndex +fromDecoratedIndex networkId m = C.UTxO . Map.fromList <$> traverse toCardanoUtxo (Map.toList m) + where + toCardanoUtxo (outRef, txOut) = do + txOut' <- toCtxUTxOTxOut <$> toTxOut networkId txOut + txIn <- CardanoAPI.toCardanoTxIn outRef + pure (txIn, txOut') + +instance Pretty DecoratedTxOut where + pretty p = + hang 2 $ + vsep + [ "-" <+> pretty (p ^. decoratedTxOutValue) <+> "addressed to", + pretty (p ^. decoratedTxOutAddress) + ] + +instance Pretty CardanoTx where + pretty tx = + let renderScriptWitnesses (CardanoEmulatorEraTx (C.Api.Tx (C.Api.ShelleyTxBody _ _ scripts _ _ _) _)) = + [hang 2 (vsep ("attached scripts:" : fmap viaShow scripts)) | not (null scripts)] + lines' = + [ hang 2 (vsep ("inputs:" : fmap (("-" <+>) . pretty) (getCardanoTxInputs tx))), + hang 2 (vsep ("reference inputs:" : fmap (("-" <+>) . pretty) (getCardanoTxReferenceInputs tx))), + hang 2 (vsep ("collateral inputs:" : fmap (("-" <+>) . pretty) (getCardanoTxCollateralInputs tx))), + hang 2 (vsep ("outputs:" : fmap pretty (getCardanoTxOutputs tx))) + ] + <> maybe + [] + (\out -> [hang 2 (vsep ["return collateral:", pretty out])]) + (getCardanoTxReturnCollateral tx) + <> maybe [] (\val -> ["total collateral:" <+> pretty val]) (getCardanoTxTotalCollateral tx) + ++ [ "mint:" <+> pretty (getCardanoTxMint tx), + "fee:" <+> pretty (getCardanoTxFee tx), + "validity range:" <+> viaShow (getCardanoTxValidityRange tx), + hang 2 (vsep ("data:" : fmap pretty (Map.toList (getCardanoTxData tx)))), + hang + 2 + ( vsep + ( "redeemers:" + : fmap + (\(k, V2.Redeemer red) -> viaShow k <+> ":" <+> viaShow red) + (Map.toList $ getCardanoTxRedeemers tx) + ) + ) + ] + ++ [ hang 2 (vsep ("required signatures:" : (viaShow <$> wits))) + | let wits = getCardanoTxExtraKeyWitnesses tx, + not (null wits) + ] + ++ renderScriptWitnesses tx + in nest 2 $ vsep ["Tx" <+> pretty (getCardanoTxId tx) <> colon, vsep lines'] + +instance Pretty CardanoAPI.CardanoBuildTx where + pretty txBodyContent = case C.makeSignedTransaction [] <$> CardanoAPI.createTransactionBody txBodyContent of + Right tx -> pretty $ CardanoEmulatorEraTx tx + _ -> viaShow txBodyContent + +getTxBodyContent :: CardanoTx -> C.TxBodyContent C.ViewTx C.ConwayEra +getTxBodyContent (CardanoEmulatorEraTx (C.Tx (C.TxBody bodyContent) _)) = bodyContent + +getCardanoTxId :: CardanoTx -> C.TxId +getCardanoTxId = getCardanoApiTxId + +getCardanoApiTxId :: CardanoTx -> C.TxId +getCardanoApiTxId (CardanoTx (C.Tx body _) _) = C.getTxId body + +getCardanoTxInputs :: CardanoTx -> [C.TxIn] +getCardanoTxInputs = getTxBodyContentInputs . getTxBodyContent + +getTxBodyContentInputs :: C.TxBodyContent ctx era -> [C.TxIn] +getTxBodyContentInputs C.TxBodyContent {..} = + fmap fst txIns + +getCardanoTxCollateralInputs :: CardanoTx -> [C.TxIn] +getCardanoTxCollateralInputs = getTxBodyContentCollateralInputs . getTxBodyContent + +getTxBodyContentCollateralInputs :: C.TxBodyContent ctx era -> [C.TxIn] +getTxBodyContentCollateralInputs C.TxBodyContent {..} = CardanoAPI.fromCardanoTxInsCollateral txInsCollateral + +getCardanoTxReferenceInputs :: CardanoTx -> [C.TxIn] +getCardanoTxReferenceInputs (CardanoTx (C.Tx (C.TxBody C.TxBodyContent {..}) _) _) = + txInsReferenceToTxIns txInsReference + where + txInsReferenceToTxIns C.TxInsReferenceNone = [] + txInsReferenceToTxIns (C.TxInsReference _ txIns') = txIns' + +getCardanoTxOutRefs :: CardanoTx -> [(TxOut, C.TxIn)] +getCardanoTxOutRefs (CardanoEmulatorEraTx (C.Tx txBody@(C.TxBody C.TxBodyContent {..}) _)) = + mkOut <$> zip [0 ..] (coerce txOuts) + where + mkOut (i, o) = (o, C.TxIn (C.getTxId txBody) (C.TxIx i)) + +getCardanoTxOutputs :: CardanoTx -> [TxOut] +getCardanoTxOutputs = fmap fst . getCardanoTxOutRefs + +getCardanoTxProducedOutputs :: CardanoTx -> Map C.TxIn TxOut +getCardanoTxProducedOutputs = Map.fromList . fmap swap . getCardanoTxOutRefs + +getCardanoTxSpentOutputs :: CardanoTx -> Set C.TxIn +getCardanoTxSpentOutputs = Set.fromList . getCardanoTxInputs + +getCardanoTxReturnCollateral :: CardanoTx -> Maybe TxOut +getCardanoTxReturnCollateral = getTxBodyContentReturnCollateral . getTxBodyContent + +getTxBodyContentReturnCollateral :: C.TxBodyContent ctx C.Api.ConwayEra -> Maybe TxOut +getTxBodyContentReturnCollateral C.TxBodyContent {..} = + case txReturnCollateral of + C.TxReturnCollateralNone -> Nothing + C.TxReturnCollateral _ txOut -> Just $ TxOut txOut + +getCardanoTxProducedReturnCollateral :: CardanoTx -> Map C.TxIn TxOut +getCardanoTxProducedReturnCollateral tx@(CardanoEmulatorEraTx (C.Tx (C.TxBody C.TxBodyContent {..}) _)) = + maybe Map.empty (Map.singleton (C.TxIn (getCardanoTxId tx) (C.TxIx (genericLength txOuts)))) $ + getCardanoTxReturnCollateral tx + +getCardanoTxTotalCollateral :: CardanoTx -> Maybe Coin +getCardanoTxTotalCollateral (CardanoEmulatorEraTx (C.Tx (C.TxBody C.TxBodyContent {..}) _)) = + CardanoAPI.fromCardanoTotalCollateral txTotalCollateral + +getCardanoTxFee :: CardanoTx -> Coin +getCardanoTxFee (CardanoTx (C.Tx (C.TxBody C.TxBodyContent {..}) _) _) = CardanoAPI.fromCardanoFee txFee + +getCardanoTxMint :: CardanoTx -> C.Value +getCardanoTxMint = getTxBodyContentMint . getTxBodyContent + +getTxBodyContentMint :: C.TxBodyContent ctx era -> C.Value +getTxBodyContentMint C.TxBodyContent {..} = C.txMintValueToValue txMintValue + +getCardanoTxValidityRange :: CardanoTx -> SlotRange +getCardanoTxValidityRange (CardanoTx (C.Tx (C.TxBody C.TxBodyContent {..}) _) _) = CardanoAPI.fromCardanoValidityRange txValidityLowerBound txValidityUpperBound + +getCardanoTxData :: CardanoTx -> Map V1.DatumHash V1.Datum +getCardanoTxData (CardanoEmulatorEraTx (C.Tx txBody _)) = fst $ CardanoAPI.scriptDataFromCardanoTxBody txBody + +getTxBodyContentCerts :: C.TxBodyContent ctx era -> [C.Ledger.TxCert (C.Api.ShelleyLedgerEra era)] +getTxBodyContentCerts C.TxBodyContent {..} = case txCertificates of + C.TxCertificatesNone -> mempty + C.TxCertificates _ certs _ -> C.Api.toShelleyCertificate <$> certs + +-- TODO: add txMetaData + +txBodyContentIns :: + Lens' + (C.TxBodyContent C.BuildTx C.ConwayEra) + [(C.TxIn, C.BuildTxWith C.BuildTx (C.Witness C.WitCtxTxIn C.ConwayEra))] +txBodyContentIns = lens C.txIns (\bodyContent ins -> bodyContent {C.txIns = ins}) + +txBodyContentCollateralIns :: Lens' (C.TxBodyContent C.BuildTx C.ConwayEra) [C.TxIn] +txBodyContentCollateralIns = + lens + ( \bodyContent -> case C.txInsCollateral bodyContent of + C.TxInsCollateralNone -> [] + C.TxInsCollateral _ txIns -> txIns + ) + ( \bodyContent ins -> + bodyContent + { C.txInsCollateral = case ins of [] -> C.TxInsCollateralNone; _ -> C.TxInsCollateral C.AlonzoEraOnwardsConway ins + } + ) + +txBodyContentOuts :: Lens' (C.TxBodyContent ctx C.ConwayEra) [TxOut] +txBodyContentOuts = lens (map TxOut . C.txOuts) (\bodyContent outs -> bodyContent {C.txOuts = map getTxOut outs}) + +getCardanoTxRedeemers :: CardanoTx -> V2.Tx.Redeemers +getCardanoTxRedeemers (CardanoEmulatorEraTx (C.Tx txBody _)) = snd $ CardanoAPI.scriptDataFromCardanoTxBody txBody + +getCardanoTxExtraKeyWitnesses :: CardanoTx -> [C.Hash C.PaymentKey] +getCardanoTxExtraKeyWitnesses (CardanoEmulatorEraTx (C.Tx (C.TxBody C.TxBodyContent {..}) _)) = case txExtraKeyWits of + C.Api.TxExtraKeyWitnessesNone -> mempty + C.Api.TxExtraKeyWitnesses _ txwits -> txwits + +addCardanoTxWitness :: C.Api.ShelleyWitnessSigningKey -> CardanoTx -> CardanoTx +addCardanoTxWitness witness (CardanoEmulatorEraTx ctx) = CardanoEmulatorEraTx (addWitness ctx) + where + addWitness (C.Api.ShelleyTx shelleyBasedEra (AlonzoTx body wits isValid aux)) = + C.Api.ShelleyTx shelleyBasedEra (AlonzoTx body wits' isValid aux) + where + wits' = wits <> mempty {txwitsVKey = newWits} + newWits = case fromShelleyWitnessSigningKey body of + C.Api.ShelleyKeyWitness _ wit -> Set.singleton wit + _ -> Set.empty + + fromShelleyWitnessSigningKey txBody = + C.Api.makeShelleyKeyWitness + C.shelleyBasedEra + (C.Api.ShelleyTxBody C.Api.ShelleyBasedEraConway txBody notUsed notUsed notUsed notUsed) + witness + where + notUsed = undefined -- hack so we can reuse code from cardano-api + +decoratedTxOutPlutusValue :: DecoratedTxOut -> Value +decoratedTxOutPlutusValue = CardanoAPI.fromCardanoValue . view decoratedTxOutValue diff --git a/plutus-ledger/src/Ledger/Tx/CardanoAPI.hs b/plutus-ledger/src/Ledger/Tx/CardanoAPI.hs new file mode 100644 index 000000000..cc5b94306 --- /dev/null +++ b/plutus-ledger/src/Ledger/Tx/CardanoAPI.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Interface to the transaction types from 'cardano-api' +module Ledger.Tx.CardanoAPI + ( module Ledger.Tx.CardanoAPI.Internal, + CardanoBuildTx (..), + CardanoTx (..), + fromCardanoTxInsCollateral, + fromCardanoTotalCollateral, + fromCardanoReturnCollateral, + toCardanoTotalCollateral, + toCardanoReturnCollateral, + toCardanoDatumWitness, + toCardanoTxInReferenceWitnessHeader, + toCardanoTxInScriptWitnessHeader, + toCardanoMintWitness, + ToCardanoError (..), + FromCardanoError (..), + getRequiredSigners, + + -- * Conversion from Plutus types + toPlutusIndex, + fromPlutusIndex, + fromPlutusTxOut, + fromPlutusTxOutRef, + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) +import Cardano.Ledger.BaseTypes (mkTxIxPartial) +import Cardano.Ledger.Conway qualified as Conway +import Cardano.Ledger.Conway.TxBody (ConwayTxBody (ConwayTxBody, ctbReqSignerHashes)) +import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Shelley.API qualified as C.Ledger +import Data.Bifunctor (bimap) +import Data.Map qualified as Map +import Ledger.Address qualified as P +import Ledger.Index.Internal qualified as P +import Ledger.Scripts qualified as P +import Ledger.Tx.CardanoAPI.Internal +import Ledger.Tx.Internal qualified as P +import Plutus.Script.Utils.Scripts qualified as PV1 +import PlutusLedgerApi.V1 qualified as PV1 +import PlutusLedgerApi.V3 qualified as PV3 + +toCardanoMintWitness :: + PV1.Redeemer -> + Maybe (P.Versioned PV3.TxOutRef) -> + Maybe (P.Versioned PV1.MintingPolicy) -> + Either ToCardanoError (C.ScriptWitness C.WitCtxMint C.ConwayEra) +toCardanoMintWitness _ Nothing Nothing = Left MissingMintingPolicy +toCardanoMintWitness redeemer (Just ref) _ = + toCardanoScriptWitness C.NoScriptDatumForMint redeemer (Right ref) +toCardanoMintWitness redeemer _ (Just script) = + toCardanoScriptWitness C.NoScriptDatumForMint redeemer (Left (fmap P.getMintingPolicy script)) + +toCardanoScriptWitness :: + (PV1.ToData a) => + C.ScriptDatum witctx -> + a -> + Either (P.Versioned PV1.Script) (P.Versioned PV3.TxOutRef) -> + Either ToCardanoError (C.ScriptWitness witctx C.ConwayEra) +toCardanoScriptWitness datum redeemer scriptOrRef = + ( case scriptOrRef of + Left script -> pure $ toCardanoTxInScriptWitnessHeader script + Right ref -> toCardanoTxInReferenceWitnessHeader ref + ) + <*> pure datum + <*> pure (C.unsafeHashableScriptData $ C.fromPlutusData $ PV1.toData redeemer) + <*> pure zeroExecutionUnits + +fromCardanoTxInsCollateral :: C.TxInsCollateral era -> [C.TxIn] +fromCardanoTxInsCollateral C.TxInsCollateralNone = [] +fromCardanoTxInsCollateral (C.TxInsCollateral _ txIns) = txIns + +toCardanoDatumWitness :: Maybe PV1.Datum -> C.ScriptDatum C.WitCtxTxIn +toCardanoDatumWitness = maybe C.InlineScriptDatum (C.ScriptDatumForTxIn . Just . toCardanoScriptData . PV1.getDatum) + +type WitnessHeader witctx = + C.ScriptDatum witctx -> C.ScriptRedeemer -> C.ExecutionUnits -> C.ScriptWitness witctx C.ConwayEra + +toCardanoTxInReferenceWitnessHeader :: + P.Versioned PV3.TxOutRef -> Either ToCardanoError (WitnessHeader witctx) +toCardanoTxInReferenceWitnessHeader (P.Versioned ref lang) = do + txIn <- toCardanoTxIn ref + pure $ case lang of + P.PlutusV1 -> + C.PlutusScriptWitness C.PlutusScriptV1InConway C.PlutusScriptV1 $ C.PReferenceScript txIn + P.PlutusV2 -> + C.PlutusScriptWitness C.PlutusScriptV2InConway C.PlutusScriptV2 $ C.PReferenceScript txIn + P.PlutusV3 -> + C.PlutusScriptWitness C.PlutusScriptV3InConway C.PlutusScriptV3 $ C.PReferenceScript txIn + +toCardanoTxInScriptWitnessHeader :: P.Versioned PV1.Script -> WitnessHeader witctx +toCardanoTxInScriptWitnessHeader script = + case toCardanoScriptInEra script of + C.ScriptInEra _ (C.SimpleScript _) -> error "toCardanoTxInScriptWitnessHeader: impossible simple script" + C.ScriptInEra era (C.PlutusScript v s) -> + C.PlutusScriptWitness era v (C.PScript s) + +fromCardanoTotalCollateral :: C.TxTotalCollateral C.ConwayEra -> Maybe C.Ledger.Coin +fromCardanoTotalCollateral C.TxTotalCollateralNone = Nothing +fromCardanoTotalCollateral (C.TxTotalCollateral _ lv) = Just lv + +toCardanoTotalCollateral :: Maybe C.Ledger.Coin -> C.TxTotalCollateral C.ConwayEra +toCardanoTotalCollateral = + maybe + C.TxTotalCollateralNone + (C.TxTotalCollateral C.BabbageEraOnwardsConway) + +fromCardanoReturnCollateral :: C.TxReturnCollateral C.CtxTx C.ConwayEra -> Maybe P.TxOut +fromCardanoReturnCollateral C.TxReturnCollateralNone = Nothing +fromCardanoReturnCollateral (C.TxReturnCollateral _ txOut) = Just $ P.TxOut txOut + +toCardanoReturnCollateral :: Maybe P.TxOut -> C.TxReturnCollateral C.CtxTx C.ConwayEra +toCardanoReturnCollateral = + maybe + C.TxReturnCollateralNone + (C.TxReturnCollateral C.BabbageEraOnwardsConway . P.getTxOut) + +getRequiredSigners :: C.Tx C.ConwayEra -> [P.PaymentPubKeyHash] +getRequiredSigners (C.ShelleyTx _ (AlonzoTx ConwayTxBody {ctbReqSignerHashes = rsq} _ _ _)) = + foldMap + (pure . P.PaymentPubKeyHash . P.toPlutusPubKeyHash . C.PaymentKeyHash . C.Ledger.coerceKeyRole) + rsq + +toPlutusIndex :: + C.Ledger.UTxO EmulatorEra -> + P.UtxoIndex +toPlutusIndex (C.Ledger.UTxO utxo) = + C.UTxO + . Map.fromList + . map (bimap C.fromShelleyTxIn (C.fromShelleyTxOut C.ShelleyBasedEraConway)) + . Map.toList + $ utxo + +fromPlutusIndex :: P.UtxoIndex -> C.Ledger.UTxO (Conway.ConwayEra StandardCrypto) +fromPlutusIndex = C.toLedgerUTxO C.ShelleyBasedEraConway + +fromPlutusTxOutRef :: PV3.TxOutRef -> Either ToCardanoError (C.Ledger.TxIn StandardCrypto) +fromPlutusTxOutRef (PV3.TxOutRef txId i) = C.Ledger.TxIn <$> fromPlutusTxId txId <*> pure (mkTxIxPartial i) + +fromPlutusTxId :: PV3.TxId -> Either ToCardanoError (C.Ledger.TxId StandardCrypto) +fromPlutusTxId = fmap C.toShelleyTxId . toCardanoTxId + +fromPlutusTxOut :: P.TxOut -> Ledger.TxOut (Conway.ConwayEra StandardCrypto) +fromPlutusTxOut = C.toShelleyTxOut C.ShelleyBasedEraConway . P.toCtxUTxOTxOut diff --git a/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs b/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs new file mode 100644 index 000000000..030ca5cb7 --- /dev/null +++ b/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs @@ -0,0 +1,761 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- +-- Interface to the transaction types from 'cardano-api' +module Ledger.Tx.CardanoAPI.Internal + ( CardanoBuildTx (..), + CardanoTx (..), + getEmulatorEraTx, + pattern CardanoEmulatorEraTx, + txOutRefs, + unspentOutputsTx, + fromCardanoTxId, + fromCardanoTxIn, + fromCardanoTxOutToPV1TxInfoTxOut, + fromCardanoTxOutToPV1TxInfoTxOut', + fromCardanoTxOutToPV2TxInfoTxOut, + fromCardanoTxOutToPV2TxInfoTxOut', + fromCardanoTxOutDatumHash, + fromCardanoTxOutDatumHash', + fromCardanoTxOutDatum, + fromCardanoTxOutValue, + fromCardanoAddressInEra, + fromCardanoAddress, + fromCardanoAssetId, + fromCardanoAssetName, + fromCardanoMintValue, + fromCardanoValue, + fromCardanoPolicyId, + fromCardanoFee, + fromCardanoValidityRange, + fromCardanoScriptInEra, + fromCardanoPaymentKeyHash, + fromCardanoScriptData, + fromCardanoPlutusScript, + fromCardanoScriptInAnyLang, + fromCardanoReferenceScript, + fromCardanoLovelace, + fromCardanoSlotNo, + fromTxScriptValidity, + toTxScriptValidity, + scriptDataFromCardanoTxBody, + plutusScriptsFromTxBody, + createTransactionBody, + toCardanoTxIn, + toCardanoTxOut, + toCardanoTxOutDatum, + toCardanoTxOutDatumHash, + toCardanoTxOutDatumHashFromDatum, + toCardanoTxOutDatumInline, + toCardanoTxOutNoDatum, + toCardanoTxOutValue, + toCardanoAddressInEra, + toCardanoAssetId, + toCardanoAssetName, + toCardanoPolicyId, + toCardanoValue, + toCardanoLovelace, + toCardanoFee, + adaToCardanoValue, + toCardanoValidityRange, + toCardanoScriptInEra, + toCardanoPaymentKeyHash, + toCardanoScriptData, + toCardanoScriptDataHash, + toCardanoScriptHash, + toCardanoStakeKeyHash, + toCardanoScriptInAnyLang, + toCardanoReferenceScript, + toCardanoTxId, + ToCardanoError (..), + FromCardanoError (..), + deserialiseFromRawBytes, + zeroExecutionUnits, + tag, + withIsCardanoEra, + EmulatorEra, + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.Error qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.BM.Data.Tracer (ToObject) +import Cardano.Chain.Common (addrToBase58) +import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo +import Cardano.Ledger.Alonzo.TxWits qualified as Alonzo +import Cardano.Ledger.Coin (Coin (Coin)) +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Conway.Scripts qualified as Conway +import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Crypto (StandardCrypto) +import Control.Lens ((<&>)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, (.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (Parser, parseFail, prependFailure, typeMismatch) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Data (Proxy (Proxy)) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (mapMaybe) +import Data.Tuple (swap) +import GHC.Exts +import GHC.Generics (Generic) +import Ledger.Address qualified as P +import Ledger.Scripts qualified as P +import Ledger.Slot qualified as P +import Plutus.Script.Utils.Ada qualified as Ada +import Plutus.Script.Utils.Ada qualified as P +import Plutus.Script.Utils.V2.Scripts qualified as PV2 +import Plutus.Script.Utils.Value qualified as Value +import PlutusLedgerApi.V1 qualified as PV1 +import PlutusLedgerApi.V1.Credential qualified as Credential +import PlutusLedgerApi.V1.Tx qualified as PV1 +import PlutusLedgerApi.V2 qualified as PV2 +import PlutusLedgerApi.V3 qualified as PV3 +import PlutusTx.Prelude qualified as PlutusTx +import Prettyprinter (Pretty (pretty), colon, viaShow, (<+>)) + +type EmulatorEra = ConwayEra StandardCrypto + +newtype CardanoBuildTx = CardanoBuildTx {getCardanoBuildTx :: C.TxBodyContent C.BuildTx C.ConwayEra} + deriving (Show, Eq, Generic) + +-- | Cardano tx from any era. +data CardanoTx where + CardanoTx :: C.Tx era -> C.ShelleyBasedEra era -> CardanoTx + +getEmulatorEraTx :: CardanoTx -> C.Tx C.ConwayEra +getEmulatorEraTx (CardanoTx tx C.ShelleyBasedEraConway) = tx +getEmulatorEraTx _ = error "getEmulatorEraTx: Expected a Conway tx" + +pattern CardanoEmulatorEraTx :: C.Tx C.ConwayEra -> CardanoTx +pattern CardanoEmulatorEraTx tx <- (getEmulatorEraTx -> tx) + where + CardanoEmulatorEraTx tx = CardanoTx tx C.shelleyBasedEra + +{-# COMPLETE CardanoEmulatorEraTx #-} + +instance Eq CardanoTx where + (CardanoTx tx1 C.ShelleyBasedEraShelley) == (CardanoTx tx2 C.ShelleyBasedEraShelley) = tx1 == tx2 + (CardanoTx tx1 C.ShelleyBasedEraAllegra) == (CardanoTx tx2 C.ShelleyBasedEraAllegra) = tx1 == tx2 + (CardanoTx tx1 C.ShelleyBasedEraMary) == (CardanoTx tx2 C.ShelleyBasedEraMary) = tx1 == tx2 + (CardanoTx tx1 C.ShelleyBasedEraAlonzo) == (CardanoTx tx2 C.ShelleyBasedEraAlonzo) = tx1 == tx2 + (CardanoTx tx1 C.ShelleyBasedEraBabbage) == (CardanoTx tx2 C.ShelleyBasedEraBabbage) = tx1 == tx2 + (CardanoTx tx1 C.ShelleyBasedEraConway) == (CardanoTx tx2 C.ShelleyBasedEraConway) = tx1 == tx2 + _ == _ = False + +deriving instance Show CardanoTx + +instance ToJSON CardanoTx where + toJSON (CardanoTx tx sbe) = + C.shelleyBasedEraConstraints sbe $ + object + [ "tx" .= C.serialiseToTextEnvelope Nothing tx, + "shelleyBasedEra" .= sbe + ] + +-- | Converting 'CardanoTx' to JSON. +-- +-- If the "tx" field is from an unknown era, the JSON parser will print an +-- error at runtime while parsing. +instance FromJSON CardanoTx where + parseJSON = parseSomeCardanoTx + +-- | Run code that needs an `IsCardanoEra` constraint while you only have an `EraInMode` value. +withIsCardanoEra :: C.CardanoEra era -> ((C.IsCardanoEra era) => r) -> r +withIsCardanoEra = C.cardanoEraConstraints + +parseSomeCardanoTx :: + Aeson.Value -> + Parser CardanoTx +parseSomeCardanoTx (Aeson.Object v) = do + C.AnyShelleyBasedEra sbe <- v .: "shelleyBasedEra" + envelope :: C.TextEnvelope <- v .: "tx" + tx <- + C.shelleyBasedEraConstraints sbe + $ either + (const $ parseFail "Failed to parse 'tx' field from CardanoTx") + pure + $ C.deserialiseFromTextEnvelope (C.AsTx (C.proxyToAsType Proxy)) envelope + pure $ CardanoTx tx sbe +parseSomeCardanoTx invalid = + prependFailure + "parsing CardanoTx failed, " + (typeMismatch "Object" invalid) + +txOutRefs :: CardanoTx -> [(PV1.TxOut, PV3.TxOutRef)] +txOutRefs (CardanoTx (C.Tx txBody@(C.TxBody C.TxBodyContent {..}) _) _) = + mkOut <$> zip [0 ..] plutusTxOuts + where + mkOut (i, o) = (o, PV3.TxOutRef (fromCardanoTxId $ C.getTxId txBody) i) + plutusTxOuts = fromCardanoTxOutToPV1TxInfoTxOut <$> txOuts + +unspentOutputsTx :: CardanoTx -> Map PV3.TxOutRef PV1.TxOut +unspentOutputsTx tx = Map.fromList $ swap <$> txOutRefs tx + +-- | Given a 'C.TxScriptValidity era', if the @era@ supports scripts, return a +-- @True@ or @False@ depending on script validity. If the @era@ does not support +-- scripts, always return @True@. +fromTxScriptValidity :: C.TxScriptValidity era -> Bool +fromTxScriptValidity (C.TxScriptValidity _ C.ScriptValid) = True +fromTxScriptValidity (C.TxScriptValidity _ C.ScriptInvalid) = False +fromTxScriptValidity C.TxScriptValidityNone = True + +toTxScriptValidity :: C.ShelleyBasedEra era -> Bool -> C.TxScriptValidity era +toTxScriptValidity C.ShelleyBasedEraAlonzo True = C.TxScriptValidity C.AlonzoEraOnwardsAlonzo C.ScriptValid +toTxScriptValidity C.ShelleyBasedEraAlonzo False = C.TxScriptValidity C.AlonzoEraOnwardsAlonzo C.ScriptInvalid +toTxScriptValidity C.ShelleyBasedEraBabbage True = C.TxScriptValidity C.AlonzoEraOnwardsBabbage C.ScriptValid +toTxScriptValidity C.ShelleyBasedEraBabbage False = C.TxScriptValidity C.AlonzoEraOnwardsBabbage C.ScriptInvalid +toTxScriptValidity C.ShelleyBasedEraConway True = C.TxScriptValidity C.AlonzoEraOnwardsConway C.ScriptValid +toTxScriptValidity C.ShelleyBasedEraConway False = C.TxScriptValidity C.AlonzoEraOnwardsConway C.ScriptInvalid +toTxScriptValidity _ _ = C.TxScriptValidityNone + +withShelleyBasedEraConstraintsForLedger :: + C.ShelleyBasedEra era -> ((Ledger.Era (C.ShelleyLedgerEra era)) => r) -> r +withShelleyBasedEraConstraintsForLedger = \case + C.ShelleyBasedEraShelley -> id + C.ShelleyBasedEraAllegra -> id + C.ShelleyBasedEraMary -> id + C.ShelleyBasedEraAlonzo -> id + C.ShelleyBasedEraBabbage -> id + C.ShelleyBasedEraConway -> id + +-- | Given a 'C.TxBody from a 'C.Tx era', return the datums and redeemers along +-- with their hashes. +scriptDataFromCardanoTxBody :: + C.TxBody C.ConwayEra -> + (Map P.DatumHash P.Datum, PV1.Redeemers) +-- scriptDataFromCardanoTxBody C.ByronTxBody{} = (mempty, mempty) +scriptDataFromCardanoTxBody (C.ShelleyTxBody _ _ _ C.TxBodyNoScriptData _ _) = + (mempty, mempty) +scriptDataFromCardanoTxBody + (C.ShelleyTxBody shelleyBasedEra _ _ (C.TxBodyScriptData _ (Alonzo.TxDats' dats) reds') _ _) = + withShelleyBasedEraConstraintsForLedger shelleyBasedEra $ case reds' of + (Alonzo.Redeemers reds) -> + let datums = + Map.fromList + $ fmap + ( (\d -> (P.datumHash d, d)) + . P.Datum + . fromCardanoScriptData + . C.fromAlonzoData + ) + $ Map.elems dats + redeemers = + Map.fromList + $ map + ( \(ptr, rdmr) -> + ( redeemerPtrFromCardanoRdmrPtr ptr, + P.Redeemer $ + fromCardanoScriptData $ + C.fromAlonzoData $ + fst rdmr + ) + ) + $ Map.toList reds + in (datums, redeemers) + +redeemerPtrFromCardanoRdmrPtr :: Alonzo.PlutusPurpose Alonzo.AsIx EmulatorEra -> PV1.RedeemerPtr +redeemerPtrFromCardanoRdmrPtr (Conway.ConwaySpending (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Spend (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Conway.ConwayMinting (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Mint (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Conway.ConwayCertifying (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Cert (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Conway.ConwayRewarding (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Conway.ConwayVoting (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Conway.ConwayProposing (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) + +-- | Extract plutus scripts from a Cardano API tx body. +-- +-- Note that Plutus scripts are only supported in Alonzo era and onwards. +plutusScriptsFromTxBody :: C.TxBody era -> Map P.ScriptHash (P.Versioned P.Script) +-- plutusScriptsFromTxBody C.ByronTxBody{} = mempty +plutusScriptsFromTxBody (C.ShelleyTxBody shelleyBasedEra _ scripts _ _ _) = + Map.fromList $ + mapMaybe (fmap (\s -> (P.scriptHash s, s)) . fromLedgerScript shelleyBasedEra) scripts + +-- + +-- | Convert a script from a Cardano api in shelley based era to a Plutus script along with it's hash. +-- +-- Note that Plutus scripts are only supported in Alonzo era and onwards. +fromLedgerScript :: + C.ShelleyBasedEra era -> + Ledger.Script (C.ShelleyLedgerEra era) -> + Maybe (P.Versioned P.Script) +fromLedgerScript e s = fromCardanoScriptInEra $ C.fromShelleyBasedScript e s + +createTransactionBody :: + CardanoBuildTx -> + Either ToCardanoError (C.TxBody C.ConwayEra) +createTransactionBody (CardanoBuildTx txBodyContent) = + first (TxBodyError . C.displayError) $ + C.createTransactionBody C.ShelleyBasedEraConway txBodyContent + +fromCardanoTxIn :: C.TxIn -> PV3.TxOutRef +fromCardanoTxIn (C.TxIn txId (C.TxIx txIx)) = PV3.TxOutRef (fromCardanoTxId txId) (toInteger txIx) + +toCardanoTxIn :: PV3.TxOutRef -> Either ToCardanoError C.TxIn +toCardanoTxIn (PV3.TxOutRef txId txIx) = C.TxIn <$> toCardanoTxId txId <*> pure (C.TxIx (fromInteger txIx)) + +fromCardanoTxId :: C.TxId -> PV3.TxId +fromCardanoTxId txId = PV3.TxId $ PlutusTx.toBuiltin $ C.serialiseToRawBytes txId + +toCardanoTxId :: PV3.TxId -> Either ToCardanoError C.TxId +toCardanoTxId (PV3.TxId bs) = + tag "toCardanoTxId" $ + deserialiseFromRawBytes C.AsTxId $ + PlutusTx.fromBuiltin bs + +fromCardanoTxOutToPV1TxInfoTxOut :: C.TxOut C.CtxTx era -> PV1.TxOut +fromCardanoTxOutToPV1TxInfoTxOut (C.TxOut addr value datumHash _) = + PV1.TxOut + (fromCardanoAddressInEra addr) + (fromCardanoValue $ fromCardanoTxOutValue value) + (fromCardanoTxOutDatumHash datumHash) + +fromCardanoTxOutToPV1TxInfoTxOut' :: C.TxOut C.CtxUTxO era -> PV1.TxOut +fromCardanoTxOutToPV1TxInfoTxOut' (C.TxOut addr value datumHash _) = + PV1.TxOut + (fromCardanoAddressInEra addr) + (fromCardanoValue $ fromCardanoTxOutValue value) + (fromCardanoTxOutDatumHash' datumHash) + +fromCardanoTxOutToPV2TxInfoTxOut :: C.TxOut C.CtxTx era -> PV2.TxOut +fromCardanoTxOutToPV2TxInfoTxOut (C.TxOut addr value datum refScript) = + PV2.TxOut + (fromCardanoAddressInEra addr) + (fromCardanoValue $ fromCardanoTxOutValue value) + (fromCardanoTxOutDatum datum) + (refScriptToScriptHash refScript) + +fromCardanoTxOutToPV2TxInfoTxOut' :: C.TxOut C.CtxUTxO era -> PV2.TxOut +fromCardanoTxOutToPV2TxInfoTxOut' (C.TxOut addr value datum refScript) = + PV2.TxOut + (fromCardanoAddressInEra addr) + (fromCardanoValue $ fromCardanoTxOutValue value) + (fromCardanoTxOutDatum' datum) + (refScriptToScriptHash refScript) + +refScriptToScriptHash :: C.ReferenceScript era -> Maybe PV2.ScriptHash +refScriptToScriptHash C.ReferenceScriptNone = Nothing +refScriptToScriptHash (C.ReferenceScript _ (C.ScriptInAnyLang _ s)) = + let (P.ScriptHash h) = fromCardanoScriptHash $ C.hashScript s + in Just $ PV2.ScriptHash h + +toCardanoTxOut :: + C.NetworkId -> + PV2.TxOut -> + Either ToCardanoError (C.TxOut C.CtxTx C.ConwayEra) +toCardanoTxOut networkId (PV2.TxOut addr value datum _rsHash) = + C.TxOut + <$> toCardanoAddressInEra networkId addr + <*> (toCardanoTxOutValue <$> toCardanoValue value) + <*> toCardanoTxOutDatum datum + <*> pure C.ReferenceScriptNone -- Not possible from just a hash + +{-# DEPRECATED + fromCardanoAddressInEra + "we now use Cardano address internally, if you need a plutus address use 'Ledger.Address.toPlutusAddress' " + #-} +fromCardanoAddressInEra :: C.AddressInEra era -> P.Address +fromCardanoAddressInEra = P.toPlutusAddress + +{-# DEPRECATED fromCardanoAddress "Shouldn't be used as we use Cardano address internally now" #-} +fromCardanoAddress :: C.Address addrtype -> P.Address +fromCardanoAddress (C.ByronAddress address) = + P.Address plutusCredential Nothing + where + plutusCredential :: Credential.Credential + plutusCredential = + Credential.PubKeyCredential $ + PV1.PubKeyHash $ + PlutusTx.toBuiltin $ + addrToBase58 address +fromCardanoAddress (C.ShelleyAddress _ paymentCredential stakeAddressReference) = + P.Address (fromCardanoPaymentCredential (C.fromShelleyPaymentCredential paymentCredential)) $ + fromCardanoStakeAddressReference (C.fromShelleyStakeReference stakeAddressReference) + +toCardanoAddressInEra :: + C.NetworkId -> P.Address -> Either ToCardanoError (C.AddressInEra C.ConwayEra) +toCardanoAddressInEra networkId (P.Address addressCredential addressStakingCredential) = + C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraConway) + <$> ( C.makeShelleyAddress networkId + <$> toCardanoPaymentCredential addressCredential + <*> toCardanoStakeAddressReference addressStakingCredential + ) + +{-# DEPRECATED fromCardanoPaymentCredential "Shouldn't be used as we use Cardano address internally now" #-} +fromCardanoPaymentCredential :: C.PaymentCredential -> Credential.Credential +fromCardanoPaymentCredential (C.PaymentCredentialByKey paymentKeyHash) = Credential.PubKeyCredential (fromCardanoPaymentKeyHash paymentKeyHash) +fromCardanoPaymentCredential (C.PaymentCredentialByScript scriptHash) = Credential.ScriptCredential (fromCardanoScriptHash scriptHash) + +toCardanoPaymentCredential :: Credential.Credential -> Either ToCardanoError C.PaymentCredential +toCardanoPaymentCredential (Credential.PubKeyCredential pubKeyHash) = C.PaymentCredentialByKey <$> toCardanoPaymentKeyHash (P.PaymentPubKeyHash pubKeyHash) +toCardanoPaymentCredential (Credential.ScriptCredential validatorHash) = C.PaymentCredentialByScript <$> toCardanoScriptHash validatorHash + +{-# DEPRECATED fromCardanoPaymentKeyHash "Shouldn't be used as we use Cardano address internally now" #-} +fromCardanoPaymentKeyHash :: C.Hash C.PaymentKey -> PV1.PubKeyHash +fromCardanoPaymentKeyHash paymentKeyHash = PV1.PubKeyHash $ PlutusTx.toBuiltin $ C.serialiseToRawBytes paymentKeyHash + +toCardanoPaymentKeyHash :: P.PaymentPubKeyHash -> Either ToCardanoError (C.Hash C.PaymentKey) +toCardanoPaymentKeyHash (P.PaymentPubKeyHash (PV1.PubKeyHash bs)) = + let bsx = PlutusTx.fromBuiltin bs + tg = "toCardanoPaymentKeyHash (" <> show (BS.length bsx) <> " bytes)" + in tag tg $ deserialiseFromRawBytes (C.AsHash C.AsPaymentKey) bsx + +{-# DEPRECATED fromCardanoScriptHash "Shouldn't be used as we use Cardano address internally now" #-} +fromCardanoScriptHash :: C.ScriptHash -> P.ScriptHash +fromCardanoScriptHash scriptHash = P.ScriptHash $ PlutusTx.toBuiltin $ C.serialiseToRawBytes scriptHash + +toCardanoScriptHash :: P.ScriptHash -> Either ToCardanoError C.ScriptHash +toCardanoScriptHash (P.ScriptHash bs) = tag "toCardanoScriptHash" $ deserialiseFromRawBytes C.AsScriptHash $ PlutusTx.fromBuiltin bs + +{-# DEPRECATED fromCardanoStakeAddressReference "Shouldn't be used as we use Cardano address internally now" #-} +fromCardanoStakeAddressReference :: C.StakeAddressReference -> Maybe Credential.StakingCredential +fromCardanoStakeAddressReference C.NoStakeAddress = Nothing +fromCardanoStakeAddressReference (C.StakeAddressByValue stakeCredential) = + Just (Credential.StakingHash $ fromCardanoStakeCredential stakeCredential) +fromCardanoStakeAddressReference C.StakeAddressByPointer {} = Nothing + +toCardanoStakeAddressReference :: + Maybe Credential.StakingCredential -> Either ToCardanoError C.StakeAddressReference +toCardanoStakeAddressReference Nothing = pure C.NoStakeAddress +toCardanoStakeAddressReference (Just (Credential.StakingHash credential)) = + C.StakeAddressByValue <$> toCardanoStakeCredential credential +toCardanoStakeAddressReference (Just Credential.StakingPtr {}) = Left StakingPointersNotSupported + +{-# DEPRECATED fromCardanoStakeCredential "Shouldn't be used as we use Cardano address internally now" #-} +fromCardanoStakeCredential :: C.StakeCredential -> Credential.Credential +fromCardanoStakeCredential (C.StakeCredentialByKey stakeKeyHash) = Credential.PubKeyCredential (fromCardanoStakeKeyHash stakeKeyHash) +fromCardanoStakeCredential (C.StakeCredentialByScript scriptHash) = Credential.ScriptCredential (fromCardanoScriptHash scriptHash) + +toCardanoStakeCredential :: Credential.Credential -> Either ToCardanoError C.StakeCredential +toCardanoStakeCredential (Credential.PubKeyCredential pubKeyHash) = C.StakeCredentialByKey <$> toCardanoStakeKeyHash pubKeyHash +toCardanoStakeCredential (Credential.ScriptCredential validatorHash) = C.StakeCredentialByScript <$> toCardanoScriptHash validatorHash + +fromCardanoStakeKeyHash :: C.Hash C.StakeKey -> PV1.PubKeyHash +fromCardanoStakeKeyHash stakeKeyHash = PV1.PubKeyHash $ PlutusTx.toBuiltin $ C.serialiseToRawBytes stakeKeyHash + +toCardanoStakeKeyHash :: PV1.PubKeyHash -> Either ToCardanoError (C.Hash C.StakeKey) +toCardanoStakeKeyHash (PV1.PubKeyHash bs) = + tag "toCardanoStakeKeyHash" $ + deserialiseFromRawBytes (C.AsHash C.AsStakeKey) (PlutusTx.fromBuiltin bs) + +fromCardanoTxOutValue :: C.TxOutValue era -> C.Value +fromCardanoTxOutValue = C.txOutValueToValue + +toCardanoTxOutValue :: C.Value -> C.TxOutValue C.ConwayEra +toCardanoTxOutValue = C.TxOutValueShelleyBased C.shelleyBasedEra . C.toMaryValue + +fromCardanoTxOutDatumHash :: C.TxOutDatum C.CtxTx era -> Maybe P.DatumHash +fromCardanoTxOutDatumHash C.TxOutDatumNone = Nothing +fromCardanoTxOutDatumHash (C.TxOutDatumHash _ h) = + Just $ P.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes h) +fromCardanoTxOutDatumHash (C.TxOutDatumInline _ d) = + Just $ P.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes (C.hashScriptDataBytes d)) +fromCardanoTxOutDatumHash (C.TxOutSupplementalDatum _ d) = + Just $ P.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes (C.hashScriptDataBytes d)) + +fromCardanoTxOutDatumHash' :: C.TxOutDatum C.CtxUTxO era -> Maybe P.DatumHash +fromCardanoTxOutDatumHash' C.TxOutDatumNone = Nothing +fromCardanoTxOutDatumHash' (C.TxOutDatumHash _ h) = + Just $ P.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes h) +fromCardanoTxOutDatumHash' (C.TxOutDatumInline _ d) = + Just $ P.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes (C.hashScriptDataBytes d)) + +fromCardanoTxOutDatum :: C.TxOutDatum C.CtxTx era -> PV2.OutputDatum +fromCardanoTxOutDatum C.TxOutDatumNone = + PV2.NoOutputDatum +fromCardanoTxOutDatum (C.TxOutDatumHash _ h) = + PV2.OutputDatumHash $ PV2.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes h) +fromCardanoTxOutDatum (C.TxOutDatumInline _ d) = + PV2.OutputDatum $ PV2.Datum $ fromCardanoScriptData d +fromCardanoTxOutDatum (C.TxOutSupplementalDatum _ d) = + PV2.OutputDatum $ PV2.Datum $ fromCardanoScriptData d + +fromCardanoTxOutDatum' :: C.TxOutDatum C.CtxUTxO era -> PV2.OutputDatum +fromCardanoTxOutDatum' C.TxOutDatumNone = + PV2.NoOutputDatum +fromCardanoTxOutDatum' (C.TxOutDatumHash _ h) = + PV2.OutputDatumHash $ PV2.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes h) +fromCardanoTxOutDatum' (C.TxOutDatumInline _ d) = + PV2.OutputDatum $ PV2.Datum $ fromCardanoScriptData d + +toCardanoTxOutNoDatum :: C.TxOutDatum C.CtxTx C.ConwayEra +toCardanoTxOutNoDatum = C.TxOutDatumNone + +toCardanoTxOutDatumInline :: PV2.Datum -> C.TxOutDatum C.CtxTx C.ConwayEra +toCardanoTxOutDatumInline = + C.TxOutDatumInline C.BabbageEraOnwardsConway + . C.unsafeHashableScriptData + . C.fromPlutusData + . PV2.builtinDataToData + . PV2.getDatum + +toCardanoTxOutDatumHashFromDatum :: PV2.Datum -> C.TxOutDatum ctx C.ConwayEra +toCardanoTxOutDatumHashFromDatum = + C.TxOutDatumHash C.AlonzoEraOnwardsConway + . C.hashScriptDataBytes + . C.unsafeHashableScriptData + . C.fromPlutusData + . PV2.builtinDataToData + . PV2.getDatum + +toCardanoTxOutDatumHash :: P.DatumHash -> Either ToCardanoError (C.TxOutDatum ctx C.ConwayEra) +toCardanoTxOutDatumHash datumHash = C.TxOutDatumHash C.AlonzoEraOnwardsConway <$> toCardanoScriptDataHash datumHash + +toCardanoTxOutDatum :: PV2.OutputDatum -> Either ToCardanoError (C.TxOutDatum C.CtxTx C.ConwayEra) +toCardanoTxOutDatum PV2.NoOutputDatum = pure toCardanoTxOutNoDatum +toCardanoTxOutDatum (PV2.OutputDatum d) = pure $ toCardanoTxOutDatumInline d +toCardanoTxOutDatum (PV2.OutputDatumHash dh) = toCardanoTxOutDatumHash dh + +toCardanoScriptDataHash :: P.DatumHash -> Either ToCardanoError (C.Hash C.ScriptData) +toCardanoScriptDataHash (P.DatumHash bs) = + tag + "toCardanoTxOutDatumHash" + (deserialiseFromRawBytes (C.AsHash C.AsScriptData) (PlutusTx.fromBuiltin bs)) + +{-# DEPRECATED fromCardanoMintValue "Use 'txMintValueToValue' from cardano-api instead." #-} +fromCardanoMintValue :: C.TxMintValue build era -> C.Value +fromCardanoMintValue = C.txMintValueToValue + +adaToCardanoValue :: P.Ada -> C.Value +adaToCardanoValue (P.Lovelace n) = fromList [(C.AdaAssetId, C.Quantity n)] + +fromCardanoValue :: C.Value -> Value.Value +fromCardanoValue = foldMap fromSingleton . toList + where + fromSingleton (fromCardanoAssetId -> assetClass, C.Quantity quantity) = + Value.assetClassValue assetClass quantity + +toCardanoValue :: Value.Value -> Either ToCardanoError C.Value +toCardanoValue = + fmap fromList . traverse toSingleton . Value.flattenValue + where + toSingleton (cs, tn, q) = + toCardanoAssetId (Value.assetClass cs tn) <&> (,C.Quantity q) + +fromCardanoPolicyId :: C.PolicyId -> P.MintingPolicyHash +fromCardanoPolicyId (C.PolicyId scriptHash) = P.MintingPolicyHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes scriptHash) + +toCardanoPolicyId :: P.MintingPolicyHash -> Either ToCardanoError C.PolicyId +toCardanoPolicyId (P.MintingPolicyHash bs) = + tag "toCardanoPolicyId" $ + tag + (show (BS.length (PlutusTx.fromBuiltin bs)) <> " bytes") + (deserialiseFromRawBytes C.AsPolicyId (PlutusTx.fromBuiltin bs)) + +fromCardanoAssetName :: C.AssetName -> Value.TokenName +fromCardanoAssetName (C.AssetName bs) = Value.TokenName $ PlutusTx.toBuiltin bs + +toCardanoAssetName :: Value.TokenName -> Either ToCardanoError C.AssetName +toCardanoAssetName (Value.TokenName bs) = + tag "toCardanoAssetName" $ + tag + (show (BS.length (PlutusTx.fromBuiltin bs)) <> " bytes") + (deserialiseFromRawBytes C.AsAssetName (PlutusTx.fromBuiltin bs)) + +fromCardanoAssetId :: C.AssetId -> Value.AssetClass +fromCardanoAssetId C.AdaAssetId = Value.assetClass Ada.adaSymbol Ada.adaToken +fromCardanoAssetId (C.AssetId policyId assetName) = + Value.assetClass + (Value.mpsSymbol . fromCardanoPolicyId $ policyId) + (fromCardanoAssetName assetName) + +toCardanoAssetId :: Value.AssetClass -> Either ToCardanoError C.AssetId +toCardanoAssetId (Value.AssetClass (currencySymbol, tokenName)) + | currencySymbol == Ada.adaSymbol && tokenName == Ada.adaToken = + pure C.AdaAssetId + | otherwise = + C.AssetId + <$> toCardanoPolicyId (Value.currencyMPSHash currencySymbol) + <*> toCardanoAssetName tokenName + +fromCardanoFee :: C.TxFee era -> Coin +fromCardanoFee (C.TxFeeExplicit _ lovelace) = lovelace + +toCardanoFee :: Coin -> C.TxFee C.ConwayEra +toCardanoFee = C.TxFeeExplicit C.shelleyBasedEra + +fromCardanoLovelace :: Coin -> PV1.Value +fromCardanoLovelace (Coin lovelace) = Ada.lovelaceValueOf lovelace + +toCardanoLovelace :: PV1.Value -> Either ToCardanoError Coin +toCardanoLovelace value = + if value == Ada.lovelaceValueOf lovelace + then pure . C.quantityToLovelace . C.Quantity $ lovelace + else Left ValueNotPureAda + where + Ada.Lovelace lovelace = Ada.fromValue value + +fromCardanoValidityRange :: C.TxValidityLowerBound era -> C.TxValidityUpperBound era -> P.SlotRange +fromCardanoValidityRange l u = PV1.Interval (fromCardanoValidityLowerBound l) (fromCardanoValidityUpperBound u) + +toCardanoValidityRange :: + P.SlotRange -> + Either ToCardanoError (C.TxValidityLowerBound C.ConwayEra, C.TxValidityUpperBound C.ConwayEra) +toCardanoValidityRange (PV1.Interval l u) = (,) <$> toCardanoValidityLowerBound l <*> toCardanoValidityUpperBound u + +fromCardanoValidityLowerBound :: C.TxValidityLowerBound era -> PV1.LowerBound P.Slot +fromCardanoValidityLowerBound C.TxValidityNoLowerBound = PV1.LowerBound PV1.NegInf True +fromCardanoValidityLowerBound (C.TxValidityLowerBound _ slotNo) = PV1.LowerBound (PV1.Finite $ fromCardanoSlotNo slotNo) True + +toCardanoValidityLowerBound :: + PV1.LowerBound P.Slot -> Either ToCardanoError (C.TxValidityLowerBound C.ConwayEra) +toCardanoValidityLowerBound (PV1.LowerBound PV1.NegInf _) = pure C.TxValidityNoLowerBound +toCardanoValidityLowerBound (PV1.LowerBound (PV1.Finite slotNo) closed) = + pure + . C.TxValidityLowerBound C.AllegraEraOnwardsConway + . toCardanoSlotNo + $ if slotNo < 0 then 0 else if closed then slotNo else slotNo + 1 +toCardanoValidityLowerBound (PV1.LowerBound PV1.PosInf _) = Left InvalidValidityRange + +fromCardanoValidityUpperBound :: C.TxValidityUpperBound era -> PV1.UpperBound P.Slot +fromCardanoValidityUpperBound (C.TxValidityUpperBound _ Nothing) = PV1.UpperBound PV1.PosInf True +fromCardanoValidityUpperBound (C.TxValidityUpperBound _ (Just slotNo)) = PV1.UpperBound (PV1.Finite $ fromCardanoSlotNo slotNo) False + +toCardanoValidityUpperBound :: + PV1.UpperBound P.Slot -> Either ToCardanoError (C.TxValidityUpperBound C.ConwayEra) +toCardanoValidityUpperBound (PV1.UpperBound PV1.PosInf _) = pure $ C.TxValidityUpperBound C.shelleyBasedEra Nothing +toCardanoValidityUpperBound (PV1.UpperBound (PV1.Finite slotNo) closed) = + pure . C.TxValidityUpperBound C.shelleyBasedEra . Just . toCardanoSlotNo $ + if closed then slotNo + 1 else slotNo +toCardanoValidityUpperBound (PV1.UpperBound PV1.NegInf _) = Left InvalidValidityRange + +fromCardanoSlotNo :: C.SlotNo -> P.Slot +fromCardanoSlotNo (C.SlotNo w64) = P.Slot (toInteger w64) + +toCardanoSlotNo :: P.Slot -> C.SlotNo +toCardanoSlotNo (P.Slot i) = C.SlotNo (fromInteger i) + +fromCardanoScriptData :: C.HashableScriptData -> PV1.BuiltinData +fromCardanoScriptData = PV1.dataToBuiltinData . C.toPlutusData . C.getScriptData + +toCardanoScriptData :: PV1.BuiltinData -> C.HashableScriptData +toCardanoScriptData = C.unsafeHashableScriptData . C.fromPlutusData . PV1.builtinDataToData + +fromCardanoScriptInEra :: C.ScriptInEra era -> Maybe (P.Versioned P.Script) +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV1InAlonzo (C.PlutusScript C.PlutusScriptV1 script)) = + Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV1) +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV1InBabbage (C.PlutusScript C.PlutusScriptV1 script)) = + Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV1) +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV2InBabbage (C.PlutusScript C.PlutusScriptV2 script)) = + Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV2) +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV1InConway (C.PlutusScript C.PlutusScriptV1 script)) = + Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV1) +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV2InConway (C.PlutusScript C.PlutusScriptV2 script)) = + Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV2) +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV3InConway (C.PlutusScript C.PlutusScriptV3 script)) = + Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV3) +fromCardanoScriptInEra (C.ScriptInEra _ C.SimpleScript {}) = Nothing + +toCardanoScriptInEra :: P.Versioned P.Script -> C.ScriptInEra C.ConwayEra +toCardanoScriptInEra (P.Versioned (P.Script s) P.PlutusV1) = + C.ScriptInEra C.PlutusScriptV1InConway . C.PlutusScript C.PlutusScriptV1 $ + C.PlutusScriptSerialised s +toCardanoScriptInEra (P.Versioned (P.Script s) P.PlutusV2) = + C.ScriptInEra C.PlutusScriptV2InConway . C.PlutusScript C.PlutusScriptV2 $ + C.PlutusScriptSerialised s +toCardanoScriptInEra (P.Versioned (P.Script s) P.PlutusV3) = + C.ScriptInEra C.PlutusScriptV3InConway . C.PlutusScript C.PlutusScriptV3 $ + C.PlutusScriptSerialised s + +fromCardanoPlutusScript :: C.PlutusScript lang -> P.Script +fromCardanoPlutusScript (C.PlutusScriptSerialised s) = P.Script s + +fromCardanoScriptInAnyLang :: C.ScriptInAnyLang -> Maybe (P.Versioned P.Script) +fromCardanoScriptInAnyLang (C.ScriptInAnyLang _sl (C.SimpleScript _)) = Nothing +fromCardanoScriptInAnyLang (C.ScriptInAnyLang _sl (C.PlutusScript psv ps)) = Just $ case psv of + C.PlutusScriptV1 -> P.Versioned (fromCardanoPlutusScript ps) P.PlutusV1 + C.PlutusScriptV2 -> P.Versioned (fromCardanoPlutusScript ps) P.PlutusV2 + C.PlutusScriptV3 -> P.Versioned (fromCardanoPlutusScript ps) P.PlutusV3 + +toCardanoScriptInAnyLang :: P.Versioned P.Script -> C.ScriptInAnyLang +toCardanoScriptInAnyLang (P.Versioned (P.Script s) P.PlutusV1) = + C.ScriptInAnyLang (C.PlutusScriptLanguage C.PlutusScriptV1) . C.PlutusScript C.PlutusScriptV1 $ + C.PlutusScriptSerialised s +toCardanoScriptInAnyLang (P.Versioned (P.Script s) P.PlutusV2) = + C.ScriptInAnyLang (C.PlutusScriptLanguage C.PlutusScriptV2) . C.PlutusScript C.PlutusScriptV2 $ + C.PlutusScriptSerialised s +toCardanoScriptInAnyLang (P.Versioned (P.Script s) P.PlutusV3) = + C.ScriptInAnyLang (C.PlutusScriptLanguage C.PlutusScriptV3) . C.PlutusScript C.PlutusScriptV3 $ + C.PlutusScriptSerialised s + +fromCardanoReferenceScript :: C.ReferenceScript C.ConwayEra -> Maybe (P.Versioned P.Script) +fromCardanoReferenceScript C.ReferenceScriptNone = Nothing +fromCardanoReferenceScript (C.ReferenceScript _ script) = fromCardanoScriptInAnyLang script + +toCardanoReferenceScript :: Maybe (P.Versioned P.Script) -> C.ReferenceScript C.ConwayEra +toCardanoReferenceScript (Just script) = + C.ReferenceScript C.BabbageEraOnwardsConway $ toCardanoScriptInAnyLang script +toCardanoReferenceScript Nothing = C.ReferenceScriptNone + +deserialiseFromRawBytes :: + (C.SerialiseAsRawBytes t) => C.AsType t -> ByteString -> Either ToCardanoError t +deserialiseFromRawBytes asType = either (const (Left DeserialisationError)) Right . C.deserialiseFromRawBytes asType + +tag :: String -> Either ToCardanoError t -> Either ToCardanoError t +tag s = first (Tag s) + +data FromCardanoError + = SimpleScriptsNotSupported + deriving stock (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON, ToObject) + +instance Pretty FromCardanoError where + pretty SimpleScriptsNotSupported = "Simple scripts are not supported" + +data ToCardanoError + = -- | A C.TxBodyError converted to String + TxBodyError String + | DeserialisationError + | InvalidValidityRange + | ValueNotPureAda + | OutputHasZeroAda + | StakingPointersNotSupported + | SimpleScriptsNotSupportedToCardano + | MissingInputValidator + | MissingDatum + | MissingMintingPolicy + | ScriptPurposeNotSupported PV1.ScriptTag + | MissingMintingPolicyRedeemer + | MissingStakeValidator + | UnsupportedPlutusVersion P.Language + | Tag String ToCardanoError + deriving stock (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Pretty ToCardanoError where + pretty (TxBodyError err) = "TxBodyError" <> colon <+> pretty err + pretty DeserialisationError = "ByteString deserialisation failed" + pretty InvalidValidityRange = "Invalid validity range" + pretty ValueNotPureAda = "Fee values should only contain Ada" + pretty OutputHasZeroAda = "Transaction outputs should not contain zero Ada" + pretty StakingPointersNotSupported = "Staking pointers are not supported" + pretty SimpleScriptsNotSupportedToCardano = "Simple scripts are not supported" + pretty MissingMintingPolicy = "Missing minting policy" + pretty (ScriptPurposeNotSupported p) = "Script purpose not supported:" <+> viaShow p + pretty MissingMintingPolicyRedeemer = "Missing minting policy redeemer" + pretty (UnsupportedPlutusVersion v) = "Plutus version not supported:" <+> viaShow v + pretty MissingInputValidator = "Missing input validator." + pretty MissingDatum = "Missing required datum." + pretty MissingStakeValidator = "Missing stake validator." + pretty (Tag t err) = pretty t <> colon <+> pretty err + +zeroExecutionUnits :: C.ExecutionUnits +zeroExecutionUnits = C.ExecutionUnits 0 0 diff --git a/plutus-ledger/src/Ledger/Tx/Internal.hs b/plutus-ledger/src/Ledger/Tx/Internal.hs new file mode 100644 index 000000000..6e6f60d53 --- /dev/null +++ b/plutus-ledger/src/Ledger/Tx/Internal.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} + +module Ledger.Tx.Internal + ( module Ledger.Tx.Internal, + Language (..), + TxOut (..), + TxOutRef (..), + Versioned (..), + ) +where + +import Cardano.Api (TxBodyContent (txValidityLowerBound)) +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Binary qualified as C +import Cardano.Ledger.Alonzo.Genesis () +import Codec.Serialise (Serialise, decode, encode) +import Control.Lens qualified as L +import Data.Aeson (FromJSON, ToJSON) +import Data.Map (Map) +import Data.Map qualified as Map +import GHC.Generics (Generic) +import Ledger.Address (CardanoAddress, cardanoPubKeyHash) +import Ledger.Crypto +import Ledger.DCert.Orphans () +import Ledger.Tx.Orphans () +import Ledger.Tx.Orphans.V2 () +import Plutus.Script.Utils.Scripts +import PlutusLedgerApi.V1 (Credential, DCert, dataToBuiltinData) +import PlutusLedgerApi.V1.Scripts +import PlutusLedgerApi.V3.Tx (TxOutRef (..)) +import PlutusTx (FromData (..), fromData) +import PlutusTx.Prelude qualified as PlutusTx +import Prettyprinter (Pretty (..), viaShow) + +cardanoTxOutValue :: C.TxOut ctx era -> C.Value +cardanoTxOutValue (C.TxOut _aie tov _tod _rs) = + C.txOutValueToValue tov + +txOutValue :: TxOut -> C.Value +txOutValue = cardanoTxOutValue . getTxOut + +outValue :: L.Lens TxOut TxOut C.Value (C.TxOutValue C.ConwayEra) +outValue = + L.lens + txOutValue + (\(TxOut (C.TxOut aie _ tod rs)) tov -> TxOut (C.TxOut aie tov tod rs)) + +outValue' :: L.Lens' TxOut (C.TxOutValue C.ConwayEra) +outValue' = + L.lens + (\(TxOut (C.TxOut _aie tov _tod _rs)) -> tov) + (\(TxOut (C.TxOut aie _ tod rs)) tov -> TxOut (C.TxOut aie tov tod rs)) + +-- | Stake withdrawal, if applicable the script should be included in txScripts. +data Withdrawal = Withdrawal + { -- | staking credential + withdrawalCredential :: Credential, + -- | amount of withdrawal in Lovelace, must withdraw all eligible amount + withdrawalAmount :: Integer, + -- | redeemer for script credential + withdrawalRedeemer :: Maybe Redeemer + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON, Serialise) + +instance Pretty Withdrawal where + pretty = viaShow + +data Certificate = Certificate + { certificateDcert :: DCert, + -- | redeemer for script credential + certificateRedeemer :: Maybe Redeemer + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON, Serialise) + +instance Pretty Certificate where + pretty = viaShow + +newtype TxOut = TxOut {getTxOut :: C.TxOut C.CtxTx C.ConwayEra} + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + deriving newtype (Pretty) + +instance C.ToCBOR TxOut where + toCBOR = C.toCBOR . C.toShelleyTxOut C.ShelleyBasedEraConway . toCtxUTxOTxOut + +instance C.FromCBOR TxOut where + fromCBOR = do + txout <- C.fromCBOR + pure $ TxOut $ C.fromShelleyTxOut C.ShelleyBasedEraConway txout + +instance Serialise TxOut where + encode = C.toCBOR + decode = C.fromCBOR + +toCtxUTxOTxOut :: TxOut -> C.TxOut C.CtxUTxO C.ConwayEra +toCtxUTxOTxOut = C.toCtxUTxOTxOut . getTxOut + +type ScriptsMap = Map ScriptHash (Versioned Script) + +type MintingWitnessesMap = Map MintingPolicyHash (Redeemer, Maybe (Versioned TxOutRef)) + +-- | Get a hash from the stored TxOutDatum (either directly or by hashing the inlined datum) +txOutDatumHash :: TxOut -> Maybe DatumHash +txOutDatumHash (TxOut (C.TxOut _aie _tov tod _rs)) = + case tod of + C.TxOutDatumNone -> + Nothing + C.TxOutDatumHash _era scriptDataHash -> + Just $ DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes scriptDataHash) + C.TxOutDatumInline _era scriptData -> + Just $ datumHash $ Datum $ dataToBuiltinData $ C.toPlutusData $ C.getScriptData scriptData + C.TxOutSupplementalDatum _era scriptData -> + Just $ datumHash $ Datum $ dataToBuiltinData $ C.toPlutusData $ C.getScriptData scriptData + +txOutDatum :: forall d. (FromData d) => TxOut -> Maybe d +txOutDatum (TxOut (C.TxOut _aie _tov tod _rs)) = + case tod of + C.TxOutDatumNone -> + Nothing + C.TxOutDatumHash _era _scriptDataHash -> + Nothing + C.TxOutDatumInline _era scriptData -> + fromData @d $ C.toPlutusData $ C.getScriptData scriptData + C.TxOutSupplementalDatum _era scriptData -> + fromData @d $ C.toPlutusData $ C.getScriptData scriptData + +cardanoTxOutDatumHash :: C.TxOutDatum C.CtxUTxO C.ConwayEra -> Maybe (C.Hash C.ScriptData) +cardanoTxOutDatumHash = \case + C.TxOutDatumNone -> + Nothing + C.TxOutDatumHash _era scriptDataHash -> + Just scriptDataHash + C.TxOutDatumInline _era scriptData -> Just $ C.hashScriptDataBytes scriptData + +txOutPubKey :: TxOut -> Maybe PubKeyHash +txOutPubKey (TxOut (C.TxOut aie _ _ _)) = cardanoPubKeyHash aie + +txOutAddress :: TxOut -> CardanoAddress +txOutAddress (TxOut (C.TxOut aie _tov _tod _rs)) = aie + +outAddress :: L.Lens' TxOut (C.AddressInEra C.ConwayEra) +outAddress = + L.lens + txOutAddress + (\(TxOut (C.TxOut _ tov tod rs)) aie -> TxOut (C.TxOut aie tov tod rs)) + +outDatumHash :: L.Lens TxOut TxOut (Maybe DatumHash) (C.TxOutDatum C.CtxTx C.ConwayEra) +outDatumHash = + L.lens + txOutDatumHash + (\(TxOut (C.TxOut aie tov _ rs)) tod -> TxOut (C.TxOut aie tov tod rs)) + +type ReferenceScript = C.ReferenceScript C.ConwayEra + +txOutReferenceScript :: TxOut -> ReferenceScript +txOutReferenceScript (TxOut (C.TxOut _aie _tov _tod rs)) = rs + +outReferenceScript :: L.Lens' TxOut ReferenceScript +outReferenceScript = + L.lens + txOutReferenceScript + (\(TxOut (C.TxOut aie tov tod _)) rs -> TxOut (C.TxOut aie tov tod rs)) + +lookupScript :: ScriptsMap -> ScriptHash -> Maybe (Versioned Script) +lookupScript txScripts hash = Map.lookup hash txScripts + +lookupValidator :: ScriptsMap -> ValidatorHash -> Maybe (Versioned Validator) +lookupValidator txScripts = (fmap . fmap) Validator . lookupScript txScripts . toScriptHash + where + toScriptHash (ValidatorHash b) = ScriptHash b + +lookupMintingPolicy :: ScriptsMap -> MintingPolicyHash -> Maybe (Versioned MintingPolicy) +lookupMintingPolicy txScripts = (fmap . fmap) MintingPolicy . lookupScript txScripts . toScriptHash + where + toScriptHash (MintingPolicyHash b) = ScriptHash b + +lookupStakeValidator :: ScriptsMap -> StakeValidatorHash -> Maybe (Versioned StakeValidator) +lookupStakeValidator txScripts = (fmap . fmap) StakeValidator . lookupScript txScripts . toScriptHash + where + toScriptHash (StakeValidatorHash b) = ScriptHash b + +emptyTxBodyContent :: C.TxBodyContent C.BuildTx C.ConwayEra +emptyTxBodyContent = + C.TxBodyContent + { txIns = [], + txInsCollateral = C.TxInsCollateralNone, + txMintValue = C.TxMintNone, + txFee = C.TxFeeExplicit C.shelleyBasedEra 0, + txOuts = [], + txProtocolParams = C.BuildTxWith Nothing, + txInsReference = C.TxInsReferenceNone, + txTotalCollateral = C.TxTotalCollateralNone, + txReturnCollateral = C.TxReturnCollateralNone, + txValidityLowerBound = C.TxValidityNoLowerBound, + txValidityUpperBound = C.TxValidityUpperBound C.shelleyBasedEra Nothing, + txScriptValidity = C.TxScriptValidityNone, + txExtraKeyWits = C.TxExtraKeyWitnessesNone, + txMetadata = C.TxMetadataNone, + txAuxScripts = C.TxAuxScriptsNone, + txWithdrawals = C.TxWithdrawalsNone, + txCertificates = C.TxCertificatesNone, + txUpdateProposal = C.TxUpdateProposalNone, + txProposalProcedures = Nothing, + txVotingProcedures = Nothing, + txCurrentTreasuryValue = Nothing, + txTreasuryDonation = Nothing + } diff --git a/plutus-ledger/src/Ledger/Tx/Orphans.hs b/plutus-ledger/src/Ledger/Tx/Orphans.hs new file mode 100644 index 000000000..866f5d287 --- /dev/null +++ b/plutus-ledger/src/Ledger/Tx/Orphans.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Tx.Orphans where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Codec.Serialise.Class (Serialise (..)) +import Data.Aeson + ( FromJSON (parseJSON), + KeyValue ((.=)), + ToJSON (toJSON), + Value (Object), + object, + (.:), + ) +import Data.Aeson.Types (parseFail, prependFailure, typeMismatch) +import Data.String (fromString) +import GHC.Generics (Generic) +import Ledger.Address (toPlutusAddress) +import Ledger.Address.Orphans () +import Ledger.Builtins.Orphans () +import Ledger.Credential.Orphans () +import Ledger.Scripts.Orphans () +import Ledger.Tx.Orphans.V1 () +import Ledger.Tx.Orphans.V2 () +import Ledger.Value.Orphans () +import Prettyprinter (Pretty (pretty), hang, viaShow, vsep, (<+>)) + +instance ToJSON (C.Tx C.ConwayEra) where + toJSON tx = + object ["tx" .= C.serialiseToTextEnvelope Nothing tx] + +instance FromJSON (C.Tx C.ConwayEra) where + parseJSON (Object v) = do + envelope <- v .: "tx" + either + (const $ parseFail "Failed to parse ConwayEra 'tx' field from CardanoTx") + pure + $ C.deserialiseFromTextEnvelope (C.AsTx C.AsConwayEra) envelope + parseJSON invalid = + prependFailure "parsing CardanoTx failed, " (typeMismatch "Object" invalid) + +instance (Pretty (C.TxOutDatum ctx era)) => Pretty (C.TxOut ctx era) where + pretty (C.TxOut addr v d rs) = + hang 2 $ + vsep $ + [ "-" <+> pretty (C.txOutValueToValue v) <+> "addressed to", + pretty (toPlutusAddress addr) + ] + <> case d of + C.TxOutDatumNone -> [] + _ -> [pretty d] + <> case rs of + C.ReferenceScript _ (C.ScriptInAnyLang _ s) -> + ["with reference script hash" <+> viaShow (C.hashScript s)] + C.ReferenceScriptNone -> [] + +instance Pretty (C.TxOutDatum C.CtxTx era) where + pretty C.TxOutDatumNone = "no datum" + pretty (C.TxOutDatumInline _ dv) = "with inline datum" <+> viaShow dv + pretty (C.TxOutDatumHash _ dh) = "with datum hash" <+> fromString (init . tail $ show dh) + pretty (C.TxOutSupplementalDatum _ dv) = "with supplemental datum" <+> viaShow dv + +instance Pretty (C.TxOutDatum C.CtxUTxO era) where + pretty C.TxOutDatumNone = "no datum" + pretty (C.TxOutDatumInline _ dv) = "with inline datum" <+> viaShow dv + pretty (C.TxOutDatumHash _ dh) = "with datum hash" <+> fromString (init . tail $ show dh) + +instance Pretty C.TxId where + pretty (C.TxId h) = fromString (init $ tail $ show h) + +instance Serialise C.TxId where + encode = encode . C.serialiseToRawBytes + decode = do + bs <- decode + either + (fail . show) + pure + $ C.deserialiseFromRawBytes C.AsTxId bs + +deriving instance Generic C.TxIn + +deriving instance Generic C.TxId + +deriving instance Generic C.TxIx + +deriving instance Serialise C.TxIn + +deriving newtype instance Serialise C.TxIx diff --git a/plutus-ledger/src/Ledger/Tx/Orphans/V1.hs b/plutus-ledger/src/Ledger/Tx/Orphans/V1.hs new file mode 100644 index 000000000..b72b4fca7 --- /dev/null +++ b/plutus-ledger/src/Ledger/Tx/Orphans/V1.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Tx.Orphans.V1 where + +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON (parseJSON), FromJSONKey, ToJSON (toJSON), ToJSONKey) +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import Ledger.Address.Orphans () +import Ledger.Builtins.Orphans () +import Ledger.Credential.Orphans () +import Ledger.Scripts.Orphans () +import Ledger.Value.Orphans () +import PlutusLedgerApi.V1 +import PlutusLedgerApi.V1.Bytes qualified as Bytes +import PlutusLedgerApi.V1.Tx + +deriving newtype instance Serialise LedgerBytes + +deriving anyclass instance FromJSONKey LedgerBytes + +deriving anyclass instance ToJSONKey LedgerBytes + +instance ToJSON LedgerBytes where + toJSON = JSON.String . JSON.encodeByteString . Bytes.bytes + +instance FromJSON LedgerBytes where + parseJSON v = Bytes.fromBytes <$> JSON.decodeByteString v + +deriving anyclass instance ToJSON RedeemerPtr + +deriving anyclass instance FromJSON RedeemerPtr + +deriving anyclass instance ToJSONKey RedeemerPtr + +deriving anyclass instance FromJSONKey RedeemerPtr + +deriving anyclass instance Serialise RedeemerPtr + +deriving anyclass instance ToJSON ScriptTag + +deriving anyclass instance FromJSON ScriptTag + +deriving anyclass instance Serialise ScriptTag + +deriving anyclass instance ToJSON TxOut + +deriving anyclass instance FromJSON TxOut + +deriving anyclass instance Serialise TxOut + +deriving anyclass instance ToJSON TxOutRef + +deriving anyclass instance FromJSON TxOutRef + +deriving anyclass instance ToJSONKey TxOutRef + +deriving anyclass instance FromJSONKey TxOutRef + +deriving anyclass instance Serialise TxOutRef + +deriving anyclass instance ToJSON TxId + +deriving anyclass instance FromJSON TxId + +deriving anyclass instance ToJSONKey TxId + +deriving anyclass instance FromJSONKey TxId + +deriving anyclass instance Serialise TxId diff --git a/plutus-ledger/src/Ledger/Tx/Orphans/V2.hs b/plutus-ledger/src/Ledger/Tx/Orphans/V2.hs new file mode 100644 index 000000000..5bd951420 --- /dev/null +++ b/plutus-ledger/src/Ledger/Tx/Orphans/V2.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Tx.Orphans.V2 where + +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON, ToJSON) +import Ledger.Address.Orphans () +import Ledger.Builtins.Orphans () +import Ledger.Credential.Orphans () +import Ledger.Scripts.Orphans () +import Ledger.Value.Orphans () +import PlutusLedgerApi.V2 + +deriving anyclass instance ToJSON OutputDatum + +deriving anyclass instance FromJSON OutputDatum + +deriving anyclass instance Serialise OutputDatum + +deriving anyclass instance ToJSON TxOut + +deriving anyclass instance FromJSON TxOut + +deriving anyclass instance Serialise TxOut diff --git a/plutus-ledger/src/Ledger/Typed/Scripts.hs b/plutus-ledger/src/Ledger/Typed/Scripts.hs new file mode 100644 index 000000000..db5bcff89 --- /dev/null +++ b/plutus-ledger/src/Ledger/Typed/Scripts.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +module Ledger.Typed.Scripts + ( module Export, + MintingPolicy, + Validator, + PV1.ConnectionError (..), + mkForwardingMintingPolicy, + unsafeMkTypedValidator, + -- TODO: Don't export Plutus V1 specific code from a module that doesn't mention a plutus version + PV1.ValidatorType, + PV1.mkTypedValidator, + PV1.mkTypedValidatorParam, + ) +where + +import Ledger.Typed.Scripts.Orphans as Export () +import Plutus.Script.Utils.Scripts (MintingPolicy, Validator) +import Plutus.Script.Utils.Scripts qualified as Untyped +import Plutus.Script.Utils.Typed as Export +import Plutus.Script.Utils.V1.Typed.Scripts qualified as PV1 +import Plutus.Script.Utils.V2.Typed.Scripts qualified as PV2 + +mkForwardingMintingPolicy :: Versioned Validator -> Versioned MintingPolicy +mkForwardingMintingPolicy vl@(Versioned _ PlutusV1) = Versioned (PV1.mkForwardingMintingPolicy (Untyped.validatorHash vl)) PlutusV1 +mkForwardingMintingPolicy vl@(Versioned _ PlutusV2) = Versioned (PV2.mkForwardingMintingPolicy (Untyped.validatorHash vl)) PlutusV2 +mkForwardingMintingPolicy (Versioned _ PlutusV3) = error "Stand alone forward minting policy are no longer relevant in PlutusV3" + +-- | Make a 'TypedValidator' (with no type constraints) from an untyped 'Validator' script. +unsafeMkTypedValidator :: Versioned Validator -> TypedValidator Any +unsafeMkTypedValidator vl = + TypedValidator + { tvValidator = vl, + tvValidatorHash = vh, + tvForwardingMPS = mps, + tvForwardingMPSHash = Untyped.mintingPolicyHash mps + } + where + vh = Untyped.validatorHash vl + mps = mkForwardingMintingPolicy vl diff --git a/plutus-ledger/src/Ledger/Typed/Scripts/Orphans.hs b/plutus-ledger/src/Ledger/Typed/Scripts/Orphans.hs new file mode 100644 index 000000000..e589497a6 --- /dev/null +++ b/plutus-ledger/src/Ledger/Typed/Scripts/Orphans.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ledger.Typed.Scripts.Orphans where + +import Data.Aeson (FromJSON, ToJSON) +import Ledger.Tx.Orphans () +import Plutus.Script.Utils.V1.Typed.Scripts.Validators qualified as PV1 + +deriving instance ToJSON (PV1.TypedValidator a) + +deriving instance FromJSON (PV1.TypedValidator a) + +deriving instance ToJSON PV1.ConnectionError + +deriving instance FromJSON PV1.ConnectionError diff --git a/plutus-ledger/src/Ledger/Typed/Scripts/Validators.hs b/plutus-ledger/src/Ledger/Typed/Scripts/Validators.hs new file mode 100644 index 000000000..2a0daf216 --- /dev/null +++ b/plutus-ledger/src/Ledger/Typed/Scripts/Validators.hs @@ -0,0 +1,7 @@ +module Ledger.Typed.Scripts.Validators + {-# DEPRECATED "Use Plutus.Script.Utils.V1.Typed.Scripts.Validators instead" #-} + ( module Plutus.Script.Utils.V1.Typed.Scripts.Validators, + ) +where + +import Plutus.Script.Utils.V1.Typed.Scripts.Validators diff --git a/plutus-ledger/src/Ledger/Typed/Tx.hs b/plutus-ledger/src/Ledger/Typed/Tx.hs new file mode 100644 index 000000000..cae680945 --- /dev/null +++ b/plutus-ledger/src/Ledger/Typed/Tx.hs @@ -0,0 +1,11 @@ +-- | Typed transaction inputs and outputs. This module defines typed versions +-- of various ledger types. The ultimate goal is to make sure that the script +-- types attached to inputs and outputs line up, to avoid type errors at +-- validation time. +module Ledger.Typed.Tx + {-# DEPRECATED "Use Plutus.Script.Utils.V1.Typed.Scripts instead" #-} + ( module Plutus.Script.Utils.V1.Typed.Scripts, + ) +where + +import Plutus.Script.Utils.V1.Typed.Scripts diff --git a/plutus-ledger/src/Ledger/Typed/TypeUtils.hs b/plutus-ledger/src/Ledger/Typed/TypeUtils.hs new file mode 100644 index 000000000..4ce2c631b --- /dev/null +++ b/plutus-ledger/src/Ledger/Typed/TypeUtils.hs @@ -0,0 +1,7 @@ +module Ledger.Typed.TypeUtils + {-# DEPRECATED "Use Plutus.Script.Utils.Typed instead" #-} + ( module Plutus.Script.Utils.Typed, + ) +where + +import Plutus.Script.Utils.Typed diff --git a/plutus-ledger/src/Ledger/Value/CardanoAPI.hs b/plutus-ledger/src/Ledger/Value/CardanoAPI.hs new file mode 100644 index 000000000..21f258ed0 --- /dev/null +++ b/plutus-ledger/src/Ledger/Value/CardanoAPI.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Value.CardanoAPI + ( C.Value, + Coin (Coin), + C.AssetId (..), + C.PolicyId, + C.AssetName, + C.selectAsset, + C.valueToList, + C.valueFromList, + C.selectLovelace, + C.filterValue, + C.negateValue, + lovelaceToValue, + lovelaceValueOf, + adaValueOf, + isZero, + isAdaOnlyValue, + noAdaValue, + adaOnlyValue, + adaToCardanoValue, + singleton, + assetIdValue, + scale, + split, + policyId, + toCardanoValue, + fromCardanoValue, + toCardanoAssetId, + fromCardanoAssetId, + combine, + valueGeq, + valueLeq, + ) +where + +import Cardano.Api qualified as C +import Cardano.Ledger.Coin (Coin (Coin)) +import Data.Bifunctor (bimap) +import Data.List (partition) +import Data.Maybe (isJust) +import Data.Monoid (All (All, getAll)) +import Data.Ratio (denominator, numerator) +import GHC.Exts +import Ledger.Scripts (MintingPolicy (..), Versioned (..), withCardanoApiScript) +import Ledger.Tx.CardanoAPI.Internal + ( adaToCardanoValue, + fromCardanoAssetId, + fromCardanoValue, + toCardanoAssetId, + toCardanoValue, + ) +import PlutusTx.Lattice (JoinSemiLattice (..)) + +lovelaceToValue :: Coin -> C.Value +lovelaceToValue 0 = mempty +lovelaceToValue l = C.lovelaceToValue l + +lovelaceValueOf :: Integer -> C.Value +lovelaceValueOf = C.lovelaceToValue . Coin + +adaValueOf :: Rational -> C.Value +adaValueOf r = + if denominator l == 1 + then lovelaceValueOf (numerator l) + else error "Ledger.Value.CardanoAPI: value is not a whole number of lovelace" + where + l = r * 1_000_000 + +isZero :: C.Value -> Bool +isZero = all (\(_, q) -> q == 0) . toList + +isAdaOnlyValue :: C.Value -> Bool +isAdaOnlyValue = isJust . C.valueToLovelace + +noAdaValue :: C.Value -> C.Value +noAdaValue = C.filterValue (/= C.AdaAssetId) + +adaOnlyValue :: C.Value -> C.Value +adaOnlyValue = C.filterValue (== C.AdaAssetId) + +singleton :: C.PolicyId -> C.AssetName -> Integer -> C.Value +singleton pid an = assetIdValue (C.AssetId pid an) + +assetIdValue :: C.AssetId -> Integer -> C.Value +assetIdValue aid n = fromList [(aid, C.Quantity n)] + +scale :: Integer -> C.Value -> C.Value +scale i = fromList . fmap (fmap (* C.Quantity i)) . toList + +split :: C.Value -> (C.Value, C.Value) +split = bimap (C.negateValue . fromList) fromList . partition ((< 0) . snd) . toList + +policyId :: Versioned MintingPolicy -> C.PolicyId +policyId = withCardanoApiScript C.scriptPolicyId . fmap getMintingPolicy + +combine :: (Monoid m) => (C.AssetId -> C.Quantity -> C.Quantity -> m) -> C.Value -> C.Value -> m +combine f v1 v2 = merge (toList v1) (toList v2) + where + -- Merge assuming the lists are ascending (thanks to Map.toList) + merge [] [] = mempty + merge [] ((ar, qr) : rs) = f ar 0 qr <> merge [] rs + merge ((al, ql) : ls) [] = f al ql 0 <> merge ls [] + merge ls'@((al, ql) : ls) rs'@((ar, qr) : rs) = case compare al ar of + EQ -> f al ql qr <> merge ls rs + LT -> f al ql 0 <> merge ls rs' + GT -> f ar 0 qr <> merge ls' rs + +valueGeq :: C.Value -> C.Value -> Bool +valueGeq lv rv = getAll $ combine (\_ l r -> All (l >= r)) lv rv + +valueLeq :: C.Value -> C.Value -> Bool +valueLeq lv rv = getAll $ combine (\_ l r -> All (l <= r)) lv rv + +instance JoinSemiLattice C.Value where + (\/) = combine (\a ql qr -> fromList [(a, ql `max` qr)]) diff --git a/plutus-ledger/src/Ledger/Value/Orphans.hs b/plutus-ledger/src/Ledger/Value/Orphans.hs new file mode 100644 index 000000000..dd8c48a74 --- /dev/null +++ b/plutus-ledger/src/Ledger/Value/Orphans.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ledger.Value.Orphans where + +import Cardano.Api qualified as C +import Codec.Serialise (Serialise (decode)) +import Codec.Serialise.Class (Serialise (encode)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), (.:)) +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import Data.ByteString qualified as BS +import Data.Hashable (Hashable) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as E +import GHC.Exts +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Bytes qualified as Bytes +import PlutusLedgerApi.V1.Value +import PlutusTx.AssocMap qualified as Map +import PlutusTx.Prelude qualified as PlutusTx +import Prettyprinter (Pretty (pretty)) +import Prettyprinter.Extras (PrettyShow (PrettyShow)) +import Prettyprinter.Util (reflow) + +instance ToJSON CurrencySymbol where + toJSON c = + JSON.object + [ ( "unCurrencySymbol", + JSON.String + . JSON.encodeByteString + . PlutusTx.fromBuiltin + . unCurrencySymbol + $ c + ) + ] + +instance FromJSON CurrencySymbol where + parseJSON = + JSON.withObject "CurrencySymbol" $ \object -> do + raw <- object .: "unCurrencySymbol" + bytes <- JSON.decodeByteString raw + pure $ CurrencySymbol $ PlutusTx.toBuiltin bytes + +deriving anyclass instance Hashable CurrencySymbol + +deriving newtype instance Serialise CurrencySymbol + +deriving anyclass instance Hashable TokenName + +deriving newtype instance Serialise TokenName + +{- note [Roundtripping token names] +How to properly roundtrip a token name that is not valid UTF-8 through PureScript +without a big rewrite of the API? +We prefix it with a zero byte so we can recognize it when we get a bytestring value back, +and we serialize it base16 encoded, with 0x in front so it will look as a hex string. +(Browsers don't render the zero byte.) +-} + +instance ToJSON TokenName where + toJSON = + JSON.object + . pure + . (,) "unTokenName" + . JSON.toJSON + . fromTokenName + (\bs -> Text.cons '\NUL' (asBase16 bs)) + (\t -> case Text.take 1 t of "\NUL" -> Text.concat ["\NUL\NUL", t]; _ -> t) + where + -- copied from 'PlutusLedgerApi.V1.Value' because not exported + asBase16 :: BS.ByteString -> Text.Text + asBase16 bs = Text.concat ["0x", Bytes.encodeByteString bs] + + fromTokenName :: (BS.ByteString -> r) -> (Text.Text -> r) -> TokenName -> r + fromTokenName handleBytestring handleText (TokenName bs) = + either (\_ -> handleBytestring $ PlutusTx.fromBuiltin bs) handleText $ + E.decodeUtf8' (PlutusTx.fromBuiltin bs) + +instance FromJSON TokenName where + parseJSON = + JSON.withObject "TokenName" $ \object -> do + raw <- object .: "unTokenName" + fromJSONText raw + where + fromText = tokenName . E.encodeUtf8 . Text.pack . fromString . Text.unpack + fromJSONText t = case Text.take 3 t of + "\NUL0x" -> either fail (pure . tokenName) . JSON.tryDecode . Text.drop 3 $ t + "\NUL\NUL\NUL" -> pure . fromText . Text.drop 2 $ t + _ -> pure . fromText $ t + +deriving anyclass instance ToJSON AssetClass + +deriving anyclass instance FromJSON AssetClass + +deriving anyclass instance Hashable AssetClass + +deriving newtype instance Serialise AssetClass + +deriving anyclass instance ToJSON Value + +deriving anyclass instance FromJSON Value + +deriving anyclass instance Hashable Value + +deriving newtype instance Serialise Value + +-- Orphan instances for 'PlutusTx.Map' to make this work +instance (ToJSON v, ToJSON k) => ToJSON (Map.Map k v) where + toJSON = JSON.toJSON . Map.toList + +instance (FromJSON v, FromJSON k, PlutusTx.Eq k) => FromJSON (Map.Map k v) where + parseJSON v = Map.safeFromList <$> JSON.parseJSON v + +deriving anyclass instance (Ord k, Hashable k, Hashable v) => Hashable (Map.Map k v) + +deriving anyclass instance (Serialise k, Serialise v) => Serialise (Map.Map k v) + +deriving newtype instance Serialise C.Quantity + +instance Pretty C.Value where + pretty = reflow . C.renderValuePretty + +instance Serialise C.Value where + decode = fromList <$> decode + encode = encode . toList + +deriving stock instance Generic C.AssetId + +deriving anyclass instance FromJSON C.AssetId + +deriving anyclass instance ToJSON C.AssetId + +deriving anyclass instance Serialise C.AssetId + +deriving via (PrettyShow C.AssetId) instance Pretty C.AssetId + +instance Serialise C.PolicyId where + encode = encode . C.serialiseToRawBytes + decode = do + bs <- decode + either + (fail . show) + pure + $ C.deserialiseFromRawBytes C.AsPolicyId bs + +instance Serialise C.AssetName where + encode = encode . C.serialiseToRawBytes + decode = do + bs <- decode + either + (fail . show) + pure + $ C.deserialiseFromRawBytes C.AsAssetName bs diff --git a/plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs b/plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs new file mode 100644 index 000000000..456bc4f3a --- /dev/null +++ b/plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wmissing-import-lists #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +module Ledger.Tx.CardanoAPISpec (tests) where + +import Cardano.Api + ( AsType (AsPaymentKey, AsStakeKey), + Key (verificationKeyHash), + NetworkId (Mainnet, Testnet), + NetworkMagic (NetworkMagic), + PaymentCredential (PaymentCredentialByKey), + StakeAddressReference (NoStakeAddress, StakeAddressByValue), + StakeCredential, + makeShelleyAddress, + shelleyAddressInEra, + ) +import Cardano.Api qualified as C +import Cardano.Api.Shelley (StakeCredential (StakeCredentialByKey), shelleyBasedEra) +import Cardano.Api.Shelley qualified as C +import GHC.Exts (fromList) +import Hedgehog (Gen, Property, forAll, property, tripping, (===)) +import Hedgehog qualified +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Ledger (toPlutusAddress) +import Ledger.Tx.CardanoAPI + ( fromCardanoAssetName, + fromCardanoTxId, + fromCardanoValue, + toCardanoAddressInEra, + toCardanoAssetName, + toCardanoTxId, + toCardanoValue, + ) +import Ledger.Value.CardanoAPI (combine, valueGeq) +import PlutusTx.Lattice ((\/)) +import Test.Gen.Cardano.Api.Typed (genAssetName, genTxId) +import Test.Gen.Cardano.Api.Typed qualified as Gen +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testPropertyNamed) + +tests :: TestTree +tests = + testGroup + "CardanoAPI" + [ testGroup + "Ledger.Tx.CardanoAPI" + [ testPropertyNamed + "Cardano Address -> Plutus Address roundtrip" + "addressRoundTripSpec" + addressRoundTripSpec, + testPropertyNamed + "TokenName <- Cardano AssetName roundtrip" + "cardanoAssetNameRoundTrip" + cardanoAssetNameRoundTrip, + testPropertyNamed + "Plutus Value <- Cardano Value roundtrip" + "cardanoValueRoundTrip" + cardanoValueRoundTrip, + testPropertyNamed "TxId round trip" "cardanoValueRoundTrip" cardanoTxIdRoundTrip + ], + testGroup + "Ledger.Value.CardanoAPI" + [ testPropertyNamed "combineLeftId" "combineLeftId" combineLeftId, + testPropertyNamed "combineRightId" "combineRightId" combineRightId, + testPropertyNamed "valueJoinGeq" "valueJoinGeq" valueJoinGeq + ] + ] + +genValueDefault :: Gen C.Value +genValueDefault = C.fromMaryValue <$> Gen.genValueDefault C.MaryEraOnwardsConway + +cardanoAssetNameRoundTrip :: Property +cardanoAssetNameRoundTrip = property $ do + assetName <- forAll genAssetName + tripping assetName fromCardanoAssetName toCardanoAssetName + +cardanoValueRoundTrip :: Property +cardanoValueRoundTrip = property $ do + value <- forAll genValueDefault + tripping value fromCardanoValue toCardanoValue + +cardanoTxIdRoundTrip :: Property +cardanoTxIdRoundTrip = property $ do + txId <- forAll genTxId + tripping txId fromCardanoTxId toCardanoTxId + +-- | From a cardano address, we should be able to convert it to a plutus address, +-- back to the same initial cardano address. +addressRoundTripSpec :: Property +addressRoundTripSpec = property $ do + networkId <- forAll genNetworkId + shelleyAddr <- + shelleyAddressInEra shelleyBasedEra + <$> forAll + ( makeShelleyAddress networkId + <$> genPaymentCredential + <*> genStakeAddressReference + ) + let plutusAddr = toPlutusAddress shelleyAddr + case toCardanoAddressInEra networkId plutusAddr of + Left _ -> Hedgehog.assert False + Right cAddr -> cAddr === shelleyAddr + +-- Copied from Gen.Cardano.Api.Typed, because it's not exported. +genPaymentCredential :: Gen PaymentCredential +genPaymentCredential = do + vKey <- Gen.genVerificationKey AsPaymentKey + return . PaymentCredentialByKey $ verificationKeyHash vKey + +-- Copied from Gen.Cardano.Api.Typed, because it's not exported. +genStakeAddressReference :: Gen StakeAddressReference +genStakeAddressReference = + Gen.choice + [ StakeAddressByValue <$> genStakeCredential, + return NoStakeAddress + ] + +genStakeCredential :: Gen StakeCredential +genStakeCredential = do + vKey <- Gen.genVerificationKey AsStakeKey + return . StakeCredentialByKey $ verificationKeyHash vKey + +-- Copied from Gen.Cardano.Api.Typed, because it's not exported. +genNetworkId :: Gen NetworkId +genNetworkId = + Gen.choice + [ pure Mainnet, + Testnet <$> genNetworkMagic + ] + +-- Copied from Gen.Cardano.Api.Typed, because it's not exported. +genNetworkMagic :: Gen NetworkMagic +genNetworkMagic = NetworkMagic <$> Gen.word32 Range.constantBounded + +combineLeftId :: Property +combineLeftId = property $ do + valueL <- forAll genValueDefault + valueR <- forAll genValueDefault + combine (\a l _ -> fromList [(a, l)]) valueL valueR === valueL + +combineRightId :: Property +combineRightId = property $ do + valueL <- forAll genValueDefault + valueR <- forAll genValueDefault + combine (\a _ r -> fromList [(a, r)]) valueL valueR === valueR + +valueJoinGeq :: Property +valueJoinGeq = property $ do + valueL <- forAll genValueDefault + valueR <- forAll genValueDefault + let jn = valueL \/ valueR + Hedgehog.annotateShow (valueL, valueR, jn) + Hedgehog.assert (jn `valueGeq` valueL) + Hedgehog.assert (jn `valueGeq` valueR) diff --git a/plutus-ledger/test/Spec.hs b/plutus-ledger/test/Spec.hs new file mode 100644 index 000000000..9ee5a7cd5 --- /dev/null +++ b/plutus-ledger/test/Spec.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +module Main (main, genCardanoBuildTx, genCardanoTx) where + +import Cardano.Api qualified as C +import Data.Aeson qualified as JSON +import Data.Aeson.Extras qualified as JSON +import Data.Aeson.Types qualified as Aeson +import Data.ByteString.Lazy qualified as BSL +import Data.List (sort) +import Hedgehog (Property, forAll, fromGenT, property) +import Hedgehog qualified +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Ledger (Slot (Slot)) +import Ledger.Tx.CardanoAPI (CardanoBuildTx (CardanoBuildTx), CardanoTx (CardanoTx)) +import Ledger.Tx.CardanoAPI qualified as CardanoAPI +import Ledger.Tx.CardanoAPISpec qualified +import Plutus.Script.Utils.Ada qualified as Ada +import Plutus.Script.Utils.Value qualified as Value hiding (scale) +import PlutusLedgerApi.V1.Interval qualified as Interval +import Test.Gen.Cardano.Api.Typed qualified as Gen +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.HUnit qualified as HUnit +import Test.Tasty.Hedgehog (testPropertyNamed) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "all tests" + [ testGroup + "intervals" + [ testPropertyNamed "member" "intvlMember," intvlMember, + testPropertyNamed "contains" "intvlContains" intvlContains + ], + testGroup + "Etc." + [ testPropertyNamed "encodeByteString" "encodeByteStringTest," encodeByteStringTest, + testPropertyNamed "encodeSerialise" "encodeSerialiseTest" encodeSerialiseTest + ], + testGroup + "Value" + ( [ testPropertyNamed + "TokenName looks like escaped bytestring ToJSON/FromJSON" + "tokenname_escaped_roundtrip" + (jsonRoundTrip . pure $ ("\NUL0xc0ffee" :: Value.TokenName)) + ] + ++ ( let vlJson :: BSL.ByteString + vlJson = "{\"getValue\":[[{\"unCurrencySymbol\":\"ab01ff\"},[[{\"unTokenName\":\"myToken\"},50]]]]}" + vlValue = Value.singleton "ab01ff" "myToken" 50 + in byteStringJson vlJson vlValue + ) + ++ ( let vlJson :: BSL.ByteString + vlJson = "{\"getValue\":[[{\"unCurrencySymbol\":\"\"},[[{\"unTokenName\":\"\"},50]]]]}" + vlValue = Ada.lovelaceValueOf 50 + in byteStringJson vlJson vlValue + ) + ), + testGroup + "TxIn" + [ testPropertyNamed + "Check that Ord instances of TxIn match" + "txInOrdInstanceEquivalenceTest" + txInOrdInstanceEquivalenceTest + ], + testGroup + "CardanoTx" + [ testPropertyNamed "Value ToJSON/FromJSON" "genCardanoTx" (jsonRoundTrip genCardanoTx) + ], + Ledger.Tx.CardanoAPISpec.tests + ] + +intvlMember :: Property +intvlMember = property $ do + (i1, i2) <- + forAll $ + (,) + <$> Gen.integral (fromIntegral <$> Range.linearBounded @Int) + <*> Gen.integral (fromIntegral <$> Range.linearBounded @Int) + let (from, to) = (min i1 i2, max i1 i2) + i = Interval.interval (Slot from) (Slot to) + Hedgehog.assert $ Interval.member (Slot from) i || Interval.isEmpty i + Hedgehog.assert $ not (Interval.member (Slot (from - 1)) i) || Interval.isEmpty i + Hedgehog.assert $ Interval.member (Slot to) i || Interval.isEmpty i + Hedgehog.assert $ not (Interval.member (Slot (to + 1)) i) || Interval.isEmpty i + +intvlContains :: Property +intvlContains = property $ do + -- generate two intervals from a sorted list of ints + -- the outer interval contains the inner interval + ints <- + forAll $ + traverse (const $ Gen.integral (fromIntegral <$> Range.linearBounded @Int)) [(1 :: Integer) .. 4] + let [i1, i2, i3, i4] = Slot <$> sort ints + outer = Interval.interval i1 i4 + inner = Interval.interval i2 i3 + + Hedgehog.assert $ Interval.contains outer inner + +encodeByteStringTest :: Property +encodeByteStringTest = property $ do + bs <- forAll $ Gen.bytes $ Range.linear 0 1000 + let enc = JSON.String $ JSON.encodeByteString bs + result = Aeson.iparse JSON.decodeByteString enc + + Hedgehog.assert $ result == Aeson.ISuccess bs + +encodeSerialiseTest :: Property +encodeSerialiseTest = property $ do + txt <- forAll $ Gen.text (Range.linear 0 1000) Gen.unicode + let enc = JSON.String $ JSON.encodeSerialise txt + result = Aeson.iparse JSON.decodeSerialise enc + + Hedgehog.assert $ result == Aeson.ISuccess txt + +jsonRoundTrip :: (Show a, Eq a, JSON.FromJSON a, JSON.ToJSON a) => Hedgehog.Gen a -> Property +jsonRoundTrip gen = property $ do + bts <- forAll gen + let enc = JSON.toJSON bts + result = Aeson.iparse JSON.parseJSON enc + + Hedgehog.annotateShow (result, bts) + Hedgehog.assert $ result == Aeson.ISuccess bts + +byteStringJson :: + (Show a, Eq a, JSON.ToJSON a, JSON.FromJSON a) => BSL.ByteString -> a -> [TestTree] +byteStringJson jsonString value = + [ testCase "decoding" $ + HUnit.assertEqual "Simple Decode" (Right value) (JSON.eitherDecode jsonString), + testCase "encoding" $ HUnit.assertEqual "Simple Encode" jsonString (JSON.encode value) + ] + +-- | Check that Ord instances of cardano-api's 'TxIn' and plutus-ledger-api's 'TxIn' match. +txInOrdInstanceEquivalenceTest :: Property +txInOrdInstanceEquivalenceTest = property $ do + txIns <- sort <$> forAll (Gen.list (Range.singleton 10) Gen.genTxIn) + let toPlutus = map CardanoAPI.fromCardanoTxIn + let plutusTxIns = sort $ toPlutus txIns + Hedgehog.assert $ toPlutus txIns == plutusTxIns + +genCardanoBuildTx :: Hedgehog.Gen CardanoBuildTx +genCardanoBuildTx = do + tx <- Gen.genTxBodyContent C.ShelleyBasedEraConway + let tx' = + tx + { C.txCertificates = C.TxCertificatesNone, + C.txUpdateProposal = C.TxUpdateProposalNone, + C.txAuxScripts = onlyPlutusScripts $ C.txAuxScripts tx + } + pure $ CardanoBuildTx tx' + where + onlyPlutusScripts C.TxAuxScriptsNone = C.TxAuxScriptsNone + onlyPlutusScripts (C.TxAuxScripts p scripts) = C.TxAuxScripts p $ filter isPlutusScript scripts + isPlutusScript (C.ScriptInEra _ C.PlutusScript {}) = True + isPlutusScript _ = False + +-- TODO Unfortunately, there's no way to get a warning if another era has been +-- added to EraInMode. Alternative way? +genCardanoTx :: Hedgehog.Gen CardanoTx +genCardanoTx = + Gen.choice + [ genShelleyEraInCardanoModeTx, + genAllegraEraInCardanoModeTx, + genMaryEraInCardanoModeTx, + genAlonzoEraInCardanoModeTx, + genBabbageEraInCardanoModeTx, + genConwayEraInCardanoModeTx + ] + +genShelleyEraInCardanoModeTx :: Hedgehog.Gen CardanoTx +genShelleyEraInCardanoModeTx = do + tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraShelley + pure $ CardanoTx tx C.ShelleyBasedEraShelley + +genAllegraEraInCardanoModeTx :: Hedgehog.Gen CardanoTx +genAllegraEraInCardanoModeTx = do + tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraAllegra + pure $ CardanoTx tx C.ShelleyBasedEraAllegra + +genMaryEraInCardanoModeTx :: Hedgehog.Gen CardanoTx +genMaryEraInCardanoModeTx = do + tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraMary + pure $ CardanoTx tx C.ShelleyBasedEraMary + +genAlonzoEraInCardanoModeTx :: Hedgehog.Gen CardanoTx +genAlonzoEraInCardanoModeTx = do + tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraAlonzo + pure $ CardanoTx tx C.ShelleyBasedEraAlonzo + +genBabbageEraInCardanoModeTx :: Hedgehog.Gen CardanoTx +genBabbageEraInCardanoModeTx = do + tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraBabbage + pure $ CardanoTx tx C.ShelleyBasedEraBabbage + +genConwayEraInCardanoModeTx :: Hedgehog.Gen CardanoTx +genConwayEraInCardanoModeTx = do + tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraConway + pure $ CardanoTx tx C.ShelleyBasedEraConway diff --git a/plutus-script-utils/CHANGELOG.md b/plutus-script-utils/CHANGELOG.md new file mode 100644 index 000000000..f358b2281 --- /dev/null +++ b/plutus-script-utils/CHANGELOG.md @@ -0,0 +1,25 @@ + + +# 1.1.0 — 2023-01-12 + +## Removed + +- `mkUntypedMintingPolicyV1` replaced by a version agnostic function +- `mkUntypedMintingPolicyV2` replaced by a version agnostic function +- `mkUntypedStakeValidatorV1` replaced by a version agnostic function +- `mkUntypedStakeValidatorV2` replaced by a version agnostic function +- `mkUntypedValidatorV1` replaced by a version agnostic function +- `mkUntypedValidatorV2` replaced by a version agnostic function + +## Added + +- `Plutus.Script.Utils.Typed.ScriptContext` a type class that allow the creation + of an untyped minting policy, stake validator or validator. +- an instance of `Plutus.Script.Utils.Typed.ScriptContext` for `Plutus. ledger.V1.Ledger.Context.ScriptContext` +- an instance of `Plutus.Script.Utils.Typed.ScriptContext` for `Plutus. ledger.V2.Ledger.Context.ScriptContext` + +## Changed + +- The default implementation of functions in the `IsScriptContext` typeclass now + log which data they are trying to decode, to ease debugging when an invalid + binary representation of a redeemer / value or script context is sent. diff --git a/plutus-script-utils/CHANGELOG.rst b/plutus-script-utils/CHANGELOG.rst new file mode 100644 index 000000000..3c0942b36 --- /dev/null +++ b/plutus-script-utils/CHANGELOG.rst @@ -0,0 +1,11 @@ + +.. _changelog-1.2.0: + +1.2.0 — 2023-03-03 +================== + +Added +----- + +- Moved `Ledger.Value` to `Plutus.Scripts.Utils.Value` +- Moved `Ledger.Ada` to `Plutus.Scripts.Utils.Ada` diff --git a/plutus-script-utils/LICENSE b/plutus-script-utils/LICENSE new file mode 100644 index 000000000..0c8a80022 --- /dev/null +++ b/plutus-script-utils/LICENSE @@ -0,0 +1,53 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of this License; and +You must cause any modified files to carry prominent notices stating that You changed the files; and +You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and +If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. + +You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. +5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/plutus-script-utils/NOTICE b/plutus-script-utils/NOTICE new file mode 100644 index 000000000..63df78b65 --- /dev/null +++ b/plutus-script-utils/NOTICE @@ -0,0 +1,14 @@ +Copyright 2022 Input Output Global, Inc. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/plutus-script-utils/README.adoc b/plutus-script-utils/README.adoc new file mode 100644 index 000000000..105c7631c --- /dev/null +++ b/plutus-script-utils/README.adoc @@ -0,0 +1,3 @@ +=== `plutus-script-utils` + +This package defines utility functions for working with Plutus scripts diff --git a/plutus-script-utils/plutus-script-utils.cabal b/plutus-script-utils/plutus-script-utils.cabal new file mode 100644 index 000000000..16f009ac5 --- /dev/null +++ b/plutus-script-utils/plutus-script-utils.cabal @@ -0,0 +1,130 @@ +cabal-version: 3.8 +name: plutus-script-utils +version: 1.4.0.0 +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +maintainer: konstantinos.lambrou@iohk.io +author: Konstantinos Lambrou-Latreille +homepage: https://github.com/input-output-hk/plutus-apps#readme +bug-reports: https://github.com/input-output-hk/plutus-apps/issues +synopsis: Helper/utility functions for writing Plutus scripts. +description: Helper/utility functions for writing Plutus scripts. +category: Language +build-type: Simple +extra-doc-files: README.adoc + +common lang + default-language: Haskell2010 + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + MultiParamTypeClasses + ScopedTypeVariables + StandaloneDeriving + + -- See Plutus Tx readme for why we need the following flags: + -- -fobject-code -fno-ignore-interface-pragmas and -fno-omit-interface-pragmas + ghc-options: + -Wall -Wnoncanonical-monad-instances -Wno-unused-packages + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -Wmissing-import-lists + -fobject-code -fno-ignore-interface-pragmas + -fno-omit-interface-pragmas -fplugin-opt + PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt + PlutusTx.Plugin:defer-errors + + -- The limitation of plutus-tx-plugin + if (impl(ghc <9.6) || impl(ghc >=9.7)) + buildable: False + +library + import: lang + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Plutus.Script.Utils.Ada + Plutus.Script.Utils.Scripts + Plutus.Script.Utils.Typed + Plutus.Script.Utils.V1.Address + Plutus.Script.Utils.V1.Contexts + Plutus.Script.Utils.V1.Generators + Plutus.Script.Utils.V1.Scripts + Plutus.Script.Utils.V1.Tx + Plutus.Script.Utils.V1.Typed.Scripts + Plutus.Script.Utils.V1.Typed.Scripts.MonetaryPolicies + Plutus.Script.Utils.V1.Typed.Scripts.StakeValidators + Plutus.Script.Utils.V1.Typed.Scripts.Validators + Plutus.Script.Utils.V2.Address + Plutus.Script.Utils.V2.Contexts + Plutus.Script.Utils.V2.Generators + Plutus.Script.Utils.V2.Scripts + Plutus.Script.Utils.V2.Tx + Plutus.Script.Utils.V2.Typed.Scripts + Plutus.Script.Utils.V2.Typed.Scripts.MonetaryPolicies + Plutus.Script.Utils.V2.Typed.Scripts.StakeValidators + Plutus.Script.Utils.V2.Typed.Scripts.Validators + Plutus.Script.Utils.V3.Address + Plutus.Script.Utils.V3.Contexts + Plutus.Script.Utils.V3.Scripts + Plutus.Script.Utils.V3.Tx + Plutus.Script.Utils.V3.Typed.Scripts + Plutus.Script.Utils.V3.Typed.Scripts.MultiPurpose + Plutus.Script.Utils.Value + Prettyprinter.Extras + + -- The limitation of plutus-tx-plugin + if (impl(ghc <9.6) || impl(ghc >=9.7)) + buildable: False + + -------------------------- + -- Other IOG dependencies + -------------------------- + build-depends: + , cardano-api ^>=10.3 + , cardano-ledger-core + , plutus-core >=1.0.0 + , plutus-ledger-api >=1.0.0 + , plutus-tx >=1.0.0 + , plutus-tx-plugin >=1.0.0 + + ------------------------ + -- Non-IOG dependencies + ------------------------ + build-depends: + , aeson + , base >=4.9 && <5 + , bytestring + , data-default + , mtl + , optics-core + , prettyprinter + , serialise + , tagged + + -- TODO This needs to be changed to 1.35 once cardano-node creates the tag + ghc-options: -fprint-potential-instances + +test-suite plutus-ledger-test + import: lang + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + + ------------------------ + -- Non-IOG dependencies + ------------------------ + build-depends: + , base >=4.9 && <5 + , tasty diff --git a/plutus-script-utils/src/Plutus/Script/Utils/Ada.hs b/plutus-script-utils/src/Plutus/Script/Utils/Ada.hs new file mode 100644 index 000000000..ef112cd67 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/Ada.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- Otherwise we get a complaint about the 'fromIntegral' call in the generated instance of 'Integral' for 'Ada' +{-# OPTIONS_GHC -Wno-identities #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +-- | Functions for working with 'Ada' in Template Haskell. +module Plutus.Script.Utils.Ada + ( Ada (..), + getAda, + adaSymbol, + adaToken, + + -- * Constructors + fromValue, + toValue, + lovelaceOf, + adaOf, + lovelaceValueOf, + adaValueOf, + + -- * Num operations + divide, + + -- * Etc. + isZero, + ) +where + +import Codec.Serialise.Class (Serialise) +import Data.Aeson (FromJSON, ToJSON) +import Data.Fixed (Fixed (MkFixed), Micro) +import Data.Tagged (Tagged (Tagged)) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Value (CurrencySymbol (CurrencySymbol), TokenName (TokenName), Value) +import PlutusLedgerApi.V1.Value qualified as TH +import PlutusTx qualified +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude + ( AdditiveGroup, + AdditiveMonoid, + AdditiveSemigroup ((+)), + Bool, + Eq ((==)), + Integer, + Monoid, + MultiplicativeMonoid, + MultiplicativeSemigroup, + Ord, + Semigroup, + emptyByteString, + ) +import PlutusTx.Prelude qualified as P +import Prettyprinter (Pretty) +import Prelude qualified as Haskell + +{-# INLINEABLE adaSymbol #-} + +-- | The 'CurrencySymbol' of the 'Ada' currency. +adaSymbol :: CurrencySymbol +adaSymbol = CurrencySymbol emptyByteString + +{-# INLINEABLE adaToken #-} + +-- | The 'TokenName' of the 'Ada' currency. +adaToken :: TokenName +adaToken = TokenName emptyByteString + +-- | ADA, the special currency on the Cardano blockchain. The unit of Ada is Lovelace, and +-- 1M Lovelace is one Ada. +-- See note [Currencies] in 'Ledger.Validation.Value.TH'. +newtype Ada = Lovelace {getLovelace :: Integer} + deriving (Haskell.Enum) + deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Generic) + deriving anyclass (ToJSON, FromJSON) + deriving newtype + ( Eq, + Ord, + Haskell.Num, + AdditiveSemigroup, + AdditiveMonoid, + AdditiveGroup, + MultiplicativeSemigroup, + MultiplicativeMonoid, + Haskell.Integral, + Haskell.Real, + Serialise, + PlutusTx.ToData, + PlutusTx.FromData, + PlutusTx.UnsafeFromData + ) + deriving (Pretty) via (Tagged "Lovelace:" Integer) + +instance Haskell.Semigroup Ada where + Lovelace a1 <> Lovelace a2 = Lovelace (a1 + a2) + +instance Semigroup Ada where + Lovelace a1 <> Lovelace a2 = Lovelace (a1 + a2) + +instance Haskell.Monoid Ada where + mempty = Lovelace 0 + +instance Monoid Ada where + mempty = Lovelace 0 + +makeLift ''Ada + +{-# INLINEABLE getAda #-} + +-- | Get the amount of Ada (the unit of the currency Ada) in this 'Ada' value. +getAda :: Ada -> Micro +getAda (Lovelace i) = MkFixed i + +{-# INLINEABLE toValue #-} + +-- | Create a 'Value' containing only the given 'Ada'. +toValue :: Ada -> Value +toValue (Lovelace i) = TH.singleton adaSymbol adaToken i + +{-# INLINEABLE fromValue #-} + +-- | Get the 'Ada' in the given 'Value'. +fromValue :: Value -> Ada +fromValue v = Lovelace (TH.valueOf v adaSymbol adaToken) + +{-# INLINEABLE lovelaceOf #-} + +-- | Create 'Ada' representing the given quantity of Lovelace (the unit of the currency Ada). +lovelaceOf :: Integer -> Ada +lovelaceOf = Lovelace + +{-# INLINEABLE adaOf #-} + +-- | Create 'Ada' representing the given quantity of Ada (1M Lovelace). +adaOf :: Micro -> Ada +adaOf (MkFixed x) = Lovelace x + +{-# INLINEABLE lovelaceValueOf #-} + +-- | A 'Value' with the given amount of Lovelace (the currency unit). +-- +-- @lovelaceValueOf == toValue . lovelaceOf@ +lovelaceValueOf :: Integer -> Value +lovelaceValueOf = TH.singleton adaSymbol adaToken + +{-# INLINEABLE adaValueOf #-} + +-- | A 'Value' with the given amount of Ada (the currency unit). +-- +-- @adaValueOf == toValue . adaOf@ +adaValueOf :: Micro -> Value +adaValueOf (MkFixed x) = TH.singleton adaSymbol adaToken x + +{-# INLINEABLE divide #-} + +-- | Divide one 'Ada' value by another. +divide :: Ada -> Ada -> Ada +divide (Lovelace a) (Lovelace b) = Lovelace (P.divide a b) + +{-# INLINEABLE isZero #-} + +-- | Check whether an 'Ada' value is zero. +isZero :: Ada -> Bool +isZero (Lovelace i) = i == 0 diff --git a/plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs b/plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs new file mode 100644 index 000000000..81dbc62a3 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module contains functions related to versioning scripts and +-- BuiltinData, or more specifially, 'Datum's and 'Redeemer's. These functions +-- do not depend on a particular version of Plutus. +module Plutus.Script.Utils.Scripts + ( Script (..), + PV1.ScriptHash (..), + ToScript (..), + ToScriptHash (..), + ToCardanoScriptHash (..), + Language (..), + Versioned (..), + ToVersioned (..), + toCardanoAddressInConway, + Validator (..), + ToValidator (..), + ValidatorHash (..), + ToValidatorHash (..), + MintingPolicy (..), + ToMintingPolicy (..), + MintingPolicyHash (..), + ToMintingPolicyHash (..), + StakeValidator (..), + ToStakeValidator (..), + StakeValidatorHash (..), + ToStakeValidatorHash (..), + scriptCredential, + scriptCurrencySymbol, + datumHash, + redeemerHash, + dataHash, + toCardanoAPIData, + ) +where + +import Cardano.Api qualified as C.Api +import Cardano.Api.Shelley qualified as C.Api +import Cardano.Ledger.Plutus.Language (Language (PlutusV1, PlutusV2, PlutusV3)) +import Codec.Serialise (Serialise) +import Data.Aeson (FromJSON, ToJSON) +import Data.Coerce (coerce) +import Data.String (IsString) +import GHC.Generics (Generic) +import PlutusLedgerApi.Common (serialiseCompiledCode) +import PlutusLedgerApi.V1 qualified as PV1 +import PlutusLedgerApi.V1.Bytes (LedgerBytes (LedgerBytes)) +import PlutusTx (CompiledCode, makeLift) +import PlutusTx qualified +import PlutusTx.Builtins (BuiltinData) +import PlutusTx.Builtins qualified as Builtins +import PlutusTx.Prelude (BuiltinUnit) +import Prettyprinter (Pretty (pretty)) +import Prettyprinter.Extras (PrettyShow (PrettyShow)) + +{- Note [Hash computation of datums, redeemers and scripts] + +We have three options for computing the hash (each with advantages and drawbacks): + +1- Depend on `cardano-api` and use it's `Scripts.hashScriptData` and `Scripts.hashScript` +functions. +The good: most simplest way to compute the hashes. +The bad: this package has an additional pretty large dependency. + +2- Depend on `cardano-ledger` instead and use their `hashScriptData` and `hashScript`. +The good: smaller footprint than `cardano-api`. +The bad: a lower-lever library than `cardano-api`. + +3- Depend on `cardano-crypto-class`, and reimplement ourselves the hashing functions +from `cardano-ledger`. +The good: the lowest dependency footprint. +The bad: code duplication. + +However, we expect that most Plutus script devs depending on this package will +also probably depend on `cardano-api`, so the dependency on `cardano-api` should +(probably) be an non-issue. + +If this becomes an issue, we'll change the implementation. +-} + +-- * Script hashes + +-- | Extracting Plutus script hashes +class ToScriptHash a where + toScriptHash :: a -> PV1.ScriptHash + +instance ToScriptHash PV1.ScriptHash where + toScriptHash = id + +instance ToScriptHash C.Api.ScriptHash where + toScriptHash = PV1.ScriptHash . Builtins.toBuiltin . C.Api.serialiseToRawBytes + +-- | Extracting Cardano script hashes +class ToCardanoScriptHash a where + toCardanoScriptHash :: a -> C.Api.ScriptHash + +instance ToCardanoScriptHash C.Api.ScriptHash where + toCardanoScriptHash = id + +-- * Scripts + +-- | Script wrapper around a ShortByteString (SerialisedScript) +newtype Script = Script {unScript :: PV1.SerialisedScript} + deriving stock (Eq, Ord, Generic) + deriving (Serialise) via PV1.SerialisedScript + +instance Show Script where + showsPrec _ _ = showString "