From 25393522da96922680a02c3ac9222e4858ad44da Mon Sep 17 00:00:00 2001 From: Nicolas Henin Date: Fri, 2 Aug 2024 17:10:15 +0200 Subject: [PATCH] WIP --- libs/cardano-debug/src/Cardano/Debug.hs | 35 +++++++++---------- .../src/Plutus/V1/Ledger/Aeson.hs | 7 ++-- .../Marlowe/Runtime/Cardano/Feature.hs | 4 +-- .../Language/Marlowe/Runtime/ChainSync/Api.hs | 22 ++++++++---- .../Marlowe/Runtime/Integration/Common.hs | 2 +- .../Marlowe/Core/V1/Semantics/Types.hs | 4 +-- 6 files changed, 40 insertions(+), 34 deletions(-) diff --git a/libs/cardano-debug/src/Cardano/Debug.hs b/libs/cardano-debug/src/Cardano/Debug.hs index 87822308bc..9d595143a9 100644 --- a/libs/cardano-debug/src/Cardano/Debug.hs +++ b/libs/cardano-debug/src/Cardano/Debug.hs @@ -132,7 +132,7 @@ friendlyTxBodyContent friendlyTxTotalCollateral :: TxTotalCollateral era -> Aeson.Value friendlyTxTotalCollateral = \case TxTotalCollateralNone -> Null - TxTotalCollateral _ lovelace -> friendlyLovelace lovelace + TxTotalCollateral _ lovelace -> friendlyCoinLovelace lovelace friendlyTxReturnCollateral :: (IsCardanoEra era) => TxReturnCollateral CtxTx era -> Aeson.Value friendlyTxReturnCollateral = \case @@ -173,7 +173,7 @@ friendlyWithdrawals (TxWithdrawals _ withdrawals) = array [ object $ "address" .= serialiseAddress addr - : "amount" .= friendlyLovelace amount + : "amount" .= friendlyCoinLovelace amount : friendlyStakeAddress addr | (addr, amount, _) <- withdrawals ] @@ -205,7 +205,7 @@ friendlyTxOut (TxOut addr amount mdatum script) = ] datum = [ "datum" .= renderDatum mdatum - | isJust $ inEonForEraMaybe @AlonzoEraOnwards id $ shelleyBasedToCardanoEra sbe + | isJust $ inEonForEraMaybe @AlonzoEraOnwards id $ toCardanoEra sbe ] sinceAlonzo = ["reference script" .= script] in preAlonzo ++ datum ++ sinceAlonzo @@ -281,12 +281,12 @@ friendlyProtocolParametersUpdate , protocolUpdateMaxTxSize <&> ("max transaction size" .=) , protocolUpdateTxFeeFixed <&> ("transaction fee constant" .=) , protocolUpdateTxFeePerByte <&> ("transaction fee linear per byte" .=) - , protocolUpdateMinUTxOValue <&> ("min UTxO value" .=) . friendlyLovelace + , protocolUpdateMinUTxOValue <&> ("min UTxO value" .=) . friendlyCoinLovelace , protocolUpdateStakeAddressDeposit - <&> ("key registration deposit" .=) . friendlyLovelace + <&> ("key registration deposit" .=) . friendlyCoinLovelace , protocolUpdateStakePoolDeposit - <&> ("pool registration deposit" .=) . friendlyLovelace - , protocolUpdateMinPoolCost <&> ("min pool cost" .=) . friendlyLovelace + <&> ("pool registration deposit" .=) . friendlyCoinLovelace + , protocolUpdateMinPoolCost <&> ("min pool cost" .=) . friendlyCoinLovelace , protocolUpdatePoolRetireMaxEpoch <&> ("pool retirement epoch boundary" .=) , protocolUpdateStakePoolTargetNum <&> ("number of pools" .=) , protocolUpdatePoolPledgeInfluence @@ -302,7 +302,7 @@ friendlyProtocolParametersUpdate , protocolUpdateMaxValueSize <&> ("max value size" .=) , protocolUpdatePrices <&> ("execution prices" .=) . friendlyPrices , protocolUpdateUTxOCostPerByte - <&> ("UTxO storage cost per byte" .=) . friendlyLovelace + <&> ("UTxO storage cost per byte" .=) . friendlyCoinLovelace ] friendlyPrices :: ExecutionUnitPrices -> Aeson.Value @@ -356,11 +356,11 @@ friendlyMirTarget = \case "target stake addresses" .= [ object [ friendlyStakeCredential credential - , "amount" .= friendlyCoin (Coin.addDeltaCoin (Coin.Coin 0) lovelace) + , "amount" .= friendlyCoinLovelace (Coin.addDeltaCoin (Coin.Coin 0) lovelace) ] | (credential, lovelace) <- Map.toList addresses ] - SendToOppositePotMIR amount -> "send to reserves" .= friendlyCoin amount + SendToOppositePotMIR amount -> "send to reserves" .= friendlyCoinLovelace amount friendlyStakeCredential :: (Crypto.Crypto era) => Shelley.Credential 'Shelley.Staking era -> Aeson.Pair friendlyStakeCredential = \case @@ -397,10 +397,10 @@ friendlyStakePoolParameters object [ "pool" .= stakePoolId , "VRF key hash" .= serialiseToRawBytesHexText stakePoolVRF - , "cost" .= friendlyLovelace stakePoolCost + , "cost" .= friendlyCoinLovelace stakePoolCost , "margin" .= friendlyRational stakePoolMargin , "reward account" .= object (friendlyStakeAddress stakePoolRewardAccount) - , "pledge" .= friendlyLovelace stakePoolPledge + , "pledge" .= friendlyCoinLovelace stakePoolPledge , "owners (stake key hashes)" .= map serialiseToRawBytesHexText stakePoolOwners , "relays" .= map textShow stakePoolRelays @@ -419,13 +419,10 @@ friendlyRational r = friendlyFee :: TxFee era -> Aeson.Value friendlyFee = \case - TxFeeExplicit _ fee -> friendlyLovelace fee + TxFeeExplicit _ fee -> friendlyCoinLovelace fee -friendlyCoin :: Coin.Coin -> Aeson.Value -friendlyCoin (Coin.Coin value) = String $ textShow value <> " Lovelace" - -friendlyLovelace :: Lovelace -> Aeson.Value -friendlyLovelace (Lovelace value) = String $ textShow value <> " Lovelace" +friendlyCoinLovelace :: Coin.Coin -> Aeson.Value +friendlyCoinLovelace (Coin.Coin value) = String $ textShow value <> " Lovelace" friendlyMintValue :: forall era view. TxMintValue view era -> Aeson.Value friendlyMintValue = \case @@ -434,7 +431,7 @@ friendlyMintValue = \case friendlyTxOutValue :: TxOutValue era -> Aeson.Value friendlyTxOutValue = \case - TxOutValueByron lovelace -> friendlyLovelace lovelace + TxOutValueByron lovelace -> friendlyCoinLovelace lovelace TxOutValueShelleyBased era v -> friendlyValue $ fromLedgerValue era v friendlyValue :: Api.Value -> Aeson.Value diff --git a/libs/plutus-ledger-aeson/src/Plutus/V1/Ledger/Aeson.hs b/libs/plutus-ledger-aeson/src/Plutus/V1/Ledger/Aeson.hs index 7343008779..d0596f232c 100644 --- a/libs/plutus-ledger-aeson/src/Plutus/V1/Ledger/Aeson.hs +++ b/libs/plutus-ledger-aeson/src/Plutus/V1/Ledger/Aeson.hs @@ -30,6 +30,7 @@ import PlutusLedgerApi.V1.Bytes qualified as Bytes import PlutusLedgerApi.V1.Scripts import PlutusLedgerApi.V1.Tx import PlutusLedgerApi.V1.Value +import PlutusTx.Eq qualified as PlutusTx deriving anyclass instance ToJSON DatumHash deriving anyclass instance FromJSON DatumHash @@ -138,10 +139,10 @@ deriving newtype instance Serialise Value instance (ToJSON v, ToJSON k) => ToJSON (Map.Map k v) where toJSON = JSON.toJSON . Map.toList -instance (FromJSON v, FromJSON k) => FromJSON (Map.Map k v) where - parseJSON v = Map.fromList <$> JSON.parseJSON v +instance (PlutusTx.Eq k, FromJSON v, FromJSON k) => FromJSON (Map.Map k v) where + parseJSON v = Map.safeFromList <$> JSON.parseJSON v -deriving anyclass instance (Hashable k, Hashable v) => Hashable (Map.Map k 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) -- | Custom `FromJSON` instance which allows to parse a JSON number to a diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/Cardano/Feature.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/Cardano/Feature.hs index e206ba3bbc..891f22ff9e 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/Cardano/Feature.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/Cardano/Feature.hs @@ -35,7 +35,7 @@ class CardanoFeature f where class (CardanoFeature f) => ShelleyFeature f where featureInShelleyBasedEra :: ShelleyBasedEra era -> Maybe (f era) - featureInShelleyBasedEra = featureInCardanoEra . shelleyBasedToCardanoEra + featureInShelleyBasedEra = featureInCardanoEra . toCardanoEra shelleyBasedEraOfFeature :: f era -> ShelleyBasedEra era instance CardanoFeature CardanoEra where @@ -51,7 +51,7 @@ instance CardanoFeature ShelleyBasedEra where AlonzoEra -> Just ShelleyBasedEraAlonzo BabbageEra -> Just ShelleyBasedEraBabbage ConwayEra -> Just ShelleyBasedEraConway - cardanoEraOfFeature = shelleyBasedToCardanoEra + cardanoEraOfFeature = toCardanoEra instance ShelleyFeature ShelleyBasedEra where featureInShelleyBasedEra = Just diff --git a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs index 70cc9975c8..943bdd7c61 100644 --- a/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs +++ b/marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs @@ -39,7 +39,9 @@ import Cardano.Api ( ) import qualified Cardano.Api as C import qualified Cardano.Api as Cardano -import Cardano.Api.Shelley (ProtocolParameters, fromShelleyBasedScript, toShelleyScript) +import qualified Cardano.Api.Ledger as Coin +import Cardano.Api.ProtocolParameters +import Cardano.Api.Shelley (fromShelleyBasedScript, toShelleyScript) import qualified Cardano.Api.Shelley as Cardano import qualified Cardano.Ledger.BaseTypes as Base import qualified Cardano.Ledger.BaseTypes as C @@ -138,7 +140,7 @@ import qualified Network.Protocol.Query.Types as Query import Observe.Event.Render.OpenTelemetry (RenderSelectorOTel) import OpenTelemetry.Attributes (Attribute, PrimitiveAttribute (..)) import OpenTelemetry.Trace.Core (toAttribute) -import Ouroboros.Consensus.Block (EpochNo (..), EpochSize (..)) +import Ouroboros.Consensus.Block (EpochNo (..), EpochSize (..), GenesisWindow) import qualified Ouroboros.Consensus.Block as O import Ouroboros.Consensus.BlockchainTime (RelativeTime, SlotLength (..), SystemStart (..)) import Ouroboros.Consensus.HardFork.History ( @@ -151,7 +153,7 @@ import Ouroboros.Consensus.HardFork.History ( Summary (Summary), mkInterpreter, ) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCostModelParams) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCostModelParamsForTesting) import qualified PlutusLedgerApi.V1 as Plutus import Text.Read (readMaybe) import Unsafe.Coerce (unsafeCoerce) @@ -1215,7 +1217,8 @@ renderChainSyncQueryOTel = \case { requestName = "get-protocol-parameters" , requestAttributes = [] , responseAttributes = \params -> - [("protocol-parameters", toAttribute $ TextAttribute $ TL.toStrict $ encodeToLazyText params)] + [ ("protocol-parameters", toAttribute $ TextAttribute $ TL.toStrict $ encodeToLazyText params) + ] } GetSystemStart -> RequestRenderedOTel @@ -1745,8 +1748,8 @@ instance Variations ProtocolParameters instance Variations C.PraosNonce where variations = C.makePraosNonce <$> variations -instance Variations C.Lovelace where - variations = C.Lovelace <$> variations +instance Variations Coin.Coin where + variations = Coin.Coin <$> variations instance Variations C.EpochNo @@ -1757,10 +1760,11 @@ instance Variations C.AnyPlutusScriptVersion where NE.fromList [ C.AnyPlutusScriptVersion C.PlutusScriptV1 , C.AnyPlutusScriptVersion C.PlutusScriptV2 + , C.AnyPlutusScriptVersion C.PlutusScriptV3 ] instance Variations C.CostModel where - variations = pure $ C.CostModel $ Map.elems $ fromJust defaultCostModelParams + variations = pure $ C.CostModel $ Map.elems $ fromJust defaultCostModelParamsForTesting instance Variations C.ExecutionUnitPrices where variations = C.ExecutionUnitPrices <$> variations `varyAp` variations @@ -1787,6 +1791,10 @@ instance Variations EraSummary instance Variations EraParams +instance Variations GenesisWindow + +deriving instance (Generic GenesisWindow) + instance Variations SafeZone instance Variations EpochSize diff --git a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs index 93abec3514..4c4ce658a0 100644 --- a/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs +++ b/marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Common.hs @@ -299,7 +299,7 @@ balanceTx era (Wallet WalletAddresses{..} _) utxo txBodyContent = do history <- queryNode 0 C.QueryEraHistory protocol <- queryShelley 0 $ C.QueryInShelleyBasedEra era C.QueryProtocolParameters changeAddr <- - expectJust "Could not convert to Cardano address" $ toCardanoAddressInEra (C.shelleyBasedToCardanoEra era) changeAddress + expectJust "Could not convert to Cardano address" $ toCardanoAddressInEra (C.toCardanoEra era) changeAddress C.BalancedTxBody _ txBody _ _ <- withShelleyBasedEra era $ expectRight "Failed to balance Tx" $ diff --git a/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs index 9b871c5f2d..6422450f50 100644 --- a/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs +++ b/marlowe/src/Language/Marlowe/Core/V1/Semantics/Types.hs @@ -522,8 +522,8 @@ toJSONAssocMap :: (ToJSON k) => (ToJSON v) => Map k v -> JSON.Value toJSONAssocMap = toJSON . Map.toList -- | Parse an association list from JSON. -fromJSONAssocMap :: (FromJSON k) => (FromJSON v) => JSON.Value -> JSON.Parser (Map k v) -fromJSONAssocMap v = Map.fromList <$> parseJSON v +fromJSONAssocMap :: (Eq k) => (FromJSON k) => (FromJSON v) => JSON.Value -> JSON.Parser (Map k v) +fromJSONAssocMap v = Map.safeFromList <$> parseJSON v instance FromJSON Party where parseJSON = withObject "Party" $ \v ->