From 62f7907a9d55fe2faf6d03c66f4aebe025f0d621 Mon Sep 17 00:00:00 2001 From: Konstantinos Lambrou-Latreille Date: Thu, 16 Sep 2021 18:35:40 -0400 Subject: [PATCH] SCP-2753: Extract datums, redeemers and scripts when converting cardano api tx to plutus tx. --- playground-common/src/PSGenerator/Common.hs | 7 + plutus-chain-index/app/CommandLine.hs | 6 +- plutus-chain-index/plutus-chain-index.cabal | 1 + .../Plutus/ChainIndex/Emulator/DiskState.hs | 33 ++-- .../Plutus/ChainIndex/Emulator/Handlers.hs | 52 +++-- .../src/Plutus/ChainIndex/Handlers.hs | 6 +- .../src/Plutus/ChainIndex/Tx.hs | 83 ++++---- .../src/Plutus/ChainIndex/TxIdState.hs | 6 +- .../src/Plutus/ChainIndex/UtxoState.hs | 1 - .../src/Plutus/Contract/CardanoAPI.hs | 179 ++++++++++++++---- plutus-chain-index/test/Generators.hs | 4 - .../src/Plutus/V1/Ledger/Scripts.hs | 13 +- plutus-ledger/src/Ledger/Scripts.hs | 14 +- 13 files changed, 254 insertions(+), 151 deletions(-) diff --git a/playground-common/src/PSGenerator/Common.hs b/playground-common/src/PSGenerator/Common.hs index bda6c5bccf1..1dc1d45f9f8 100644 --- a/playground-common/src/PSGenerator/Common.hs +++ b/playground-common/src/PSGenerator/Common.hs @@ -215,6 +215,12 @@ languageBridge :: BridgePart languageBridge = dataBridge <|> assocMapBridge ------------------------------------------------------------ +scriptHashBridge :: BridgePart +scriptHashBridge = do + typeName ^== "ScriptHash" + typeModule ^== "Plutus.V1.Ledger.Scripts" + pure psString + scriptBridge :: BridgePart scriptBridge = do typeName ^== "Script" @@ -272,6 +278,7 @@ walletIdBridge = do ledgerBridge :: BridgePart ledgerBridge = scriptBridge + <|> scriptHashBridge <|> redeemerHashBridge <|> redeemerBridge <|> datumBridge diff --git a/plutus-chain-index/app/CommandLine.hs b/plutus-chain-index/app/CommandLine.hs index 3fef10ba318..0e84f3d8571 100644 --- a/plutus-chain-index/app/CommandLine.hs +++ b/plutus-chain-index/app/CommandLine.hs @@ -10,8 +10,8 @@ module CommandLine( import Control.Lens (over) import Options.Applicative (CommandFields, Mod, Parser, ParserInfo, argument, auto, command, flag, - fullDesc, header, help, helper, info, long, metavar, option, progDesc, short, - str, subparser, value, (<**>)) + fullDesc, header, help, helper, hsubparser, info, long, metavar, option, + progDesc, short, str, value, (<**>)) import Cardano.Api (NetworkId (..), NetworkMagic (..)) import Cardano.BM.Data.Severity @@ -111,7 +111,7 @@ cmdWithHelpParser = commandParser :: Parser Command commandParser = - subparser $ + hsubparser $ mconcat [ dumpDefaultConfigParser , dumpDefaultLoggingConfigParser diff --git a/plutus-chain-index/plutus-chain-index.cabal b/plutus-chain-index/plutus-chain-index.cabal index c6873b57a5f..8d56cb3f2ba 100644 --- a/plutus-chain-index/plutus-chain-index.cabal +++ b/plutus-chain-index/plutus-chain-index.cabal @@ -75,6 +75,7 @@ library beam-sqlite -any, beam-migrate -any, cardano-api -any, + cardano-ledger-alonzo -any, cardano-ledger-byron -any, containers -any, contra-tracer -any, diff --git a/plutus-chain-index/src/Plutus/ChainIndex/Emulator/DiskState.hs b/plutus-chain-index/src/Plutus/ChainIndex/Emulator/DiskState.hs index c80cddf4718..1fa99efc048 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/Emulator/DiskState.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/Emulator/DiskState.hs @@ -10,9 +10,7 @@ used in the emulator. module Plutus.ChainIndex.Emulator.DiskState( DiskState , dataMap - , validatorMap - , mintingPolicyMap - , stakeValidatorMap + , scriptMap , redeemerMap , txMap , addressMap @@ -30,13 +28,12 @@ import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) -import Ledger (Address (..), TxOut (..), TxOutRef) +import Ledger (Address (..), Script, ScriptHash, TxOut (..), TxOutRef) import Ledger.Credential (Credential) -import Ledger.Scripts (Datum, DatumHash, MintingPolicy, MintingPolicyHash, Redeemer, RedeemerHash, - StakeValidator, StakeValidatorHash, Validator, ValidatorHash) +import Ledger.Scripts (Datum, DatumHash, Redeemer, RedeemerHash) import Ledger.TxId (TxId) -import Plutus.ChainIndex.Tx (ChainIndexTx (..), citxData, citxMintingPolicies, citxRedeemers, - citxStakeValidators, citxTxId, citxValidators, txOutsWithRef) +import Plutus.ChainIndex.Tx (ChainIndexTx (..), citxData, citxRedeemers, citxScripts, citxTxId, + txOutsWithRef) import Plutus.ChainIndex.Types (Diagnostics (..)) -- | Set of transaction output references for each address. @@ -73,13 +70,11 @@ txCredentialMap = -- other structures for the disk-backed storage) data DiskState = DiskState - { _DataMap :: Map DatumHash Datum - , _ValidatorMap :: Map ValidatorHash Validator - , _MintingPolicyMap :: Map MintingPolicyHash MintingPolicy - , _StakeValidatorMap :: Map StakeValidatorHash StakeValidator - , _RedeemerMap :: Map RedeemerHash Redeemer - , _TxMap :: Map TxId ChainIndexTx - , _AddressMap :: CredentialMap + { _DataMap :: Map DatumHash Datum + , _ScriptMap :: Map ScriptHash Script + , _RedeemerMap :: Map RedeemerHash Redeemer + , _TxMap :: Map TxId ChainIndexTx + , _AddressMap :: CredentialMap } deriving stock (Eq, Show, Generic) deriving (Semigroup, Monoid) via (GenericSemigroupMonoid DiskState) @@ -91,19 +86,17 @@ fromTx :: ChainIndexTx -> DiskState fromTx tx = DiskState { _DataMap = view citxData tx - , _ValidatorMap = view citxValidators tx - , _MintingPolicyMap = view citxMintingPolicies tx - , _StakeValidatorMap = view citxStakeValidators tx + , _ScriptMap = view citxScripts tx , _TxMap = Map.singleton (view citxTxId tx) tx , _RedeemerMap = view citxRedeemers tx , _AddressMap = txCredentialMap tx } diagnostics :: DiskState -> Diagnostics -diagnostics DiskState{_DataMap, _ValidatorMap, _MintingPolicyMap, _TxMap, _StakeValidatorMap, _RedeemerMap, _AddressMap} = +diagnostics DiskState{_DataMap, _ScriptMap, _TxMap, _RedeemerMap, _AddressMap} = Diagnostics { numTransactions = toInteger $ Map.size _TxMap - , numScripts = toInteger $ Map.size _ValidatorMap + Map.size _MintingPolicyMap + Map.size _StakeValidatorMap + Map.size _RedeemerMap + , numScripts = toInteger $ Map.size _ScriptMap , numAddresses = toInteger $ Map.size $ _unCredentialMap _AddressMap , someTransactions = take 10 $ fmap fst $ Map.toList _TxMap } diff --git a/plutus-chain-index/src/Plutus/ChainIndex/Emulator/Handlers.hs b/plutus-chain-index/src/Plutus/ChainIndex/Emulator/Handlers.hs index 34caf480ae9..a3a5b803b9b 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/Emulator/Handlers.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/Emulator/Handlers.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-| Handlers for the 'ChainIndexQueryEffect' and the 'ChainIndexControlEffect' in the emulator -} @@ -32,13 +31,21 @@ import Data.Maybe (catMaybes, fromMaybe) import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) import qualified Data.Set as Set import GHC.Generics (Generic) -import Ledger (Address (addressCredential), ChainIndexTxOut (..), TxId, - TxOut (txOutAddress), TxOutRef (..), txOutDatumHash, txOutValue) import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..)) import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog (..)) +import Ledger (Address (addressCredential), + ChainIndexTxOut(..), + MintingPolicy (MintingPolicy), + MintingPolicyHash (MintingPolicyHash), + StakeValidator (StakeValidator), + StakeValidatorHash (StakeValidatorHash), TxId, + TxOut (txOutAddress), TxOutRef (..), Validator (Validator), + ValidatorHash (ValidatorHash), txOutDatumHash, txOutValue) +import Ledger.Scripts (ScriptHash (ScriptHash)) +import Ledger.Tx (ChainIndexTxOut (ScriptChainIndexTxOut)) import Plutus.ChainIndex.Effects (ChainIndexControlEffect (..), ChainIndexQueryEffect (..)) -import Plutus.ChainIndex.Emulator.DiskState (DiskState, addressMap, dataMap, diagnostics, mintingPolicyMap, - redeemerMap, stakeValidatorMap, txMap, validatorMap) +import Plutus.ChainIndex.Emulator.DiskState (DiskState, addressMap, dataMap, diagnostics, redeemerMap, + scriptMap, txMap) import qualified Plutus.ChainIndex.Emulator.DiskState as DiskState import Plutus.ChainIndex.Tx (ChainIndexTx, _ValidTx, citxOutputs) import Plutus.ChainIndex.Types (Tip (..), pageOf) @@ -89,14 +96,14 @@ getTxOutFromRef ref@TxOutRef{txOutRefId, txOutRefIdx} = do case addressCredential $ txOutAddress txout of PubKeyCredential _ -> pure $ Just $ PublicKeyChainIndexTxOut (txOutAddress txout) (txOutValue txout) - ScriptCredential vh -> do + ScriptCredential vh@(ValidatorHash h) -> do case txOutDatumHash txout of Nothing -> do -- If the txout comes from a script address, the Datum should not be Nothing logWarn $ NoDatumScriptAddr txout pure Nothing Just dh -> do - let v = maybe (Left vh) Right $ preview (validatorMap . ix vh) ds + let v = maybe (Left vh) (Right . Validator) $ preview (scriptMap . ix (ScriptHash h)) ds let d = maybe (Left dh) Right $ preview (dataMap . ix dh) ds pure $ Just $ ScriptChainIndexTxOut (txOutAddress txout) v d (txOutValue txout) @@ -109,9 +116,12 @@ handleQuery :: ~> Eff effs handleQuery = \case DatumFromHash h -> gets (view $ diskState . dataMap . at h) - ValidatorFromHash h -> gets (view $ diskState . validatorMap . at h) - MintingPolicyFromHash h -> gets (view $ diskState . mintingPolicyMap . at h) - StakeValidatorFromHash h -> gets (view $ diskState . stakeValidatorMap . at h) + ValidatorFromHash (ValidatorHash h) -> do + gets (fmap (fmap Validator) . view $ diskState . scriptMap . at (ScriptHash h)) + MintingPolicyFromHash (MintingPolicyHash h) -> + gets (fmap (fmap MintingPolicy) . view $ diskState . scriptMap . at (ScriptHash h)) + StakeValidatorFromHash (StakeValidatorHash h) -> + gets (fmap (fmap StakeValidator) . view $ diskState . scriptMap . at (ScriptHash h)) TxOutFromRef ref -> getTxOutFromRef ref RedeemerFromHash h -> gets (view $ diskState . redeemerMap . at h) TxFromTxId i -> getTxFromTxId i diff --git a/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs b/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs index 11097dbf98d..0e5696bf2bc 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -6,7 +5,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -240,9 +238,7 @@ fromTx :: ChainIndexTx -> Db InsertRows fromTx tx = mempty { datumRows = fromMap citxData DatumRow , scriptRows = mconcat - [ fromMap citxValidators ScriptRow - , fromMap citxMintingPolicies ScriptRow - , fromMap citxStakeValidators ScriptRow + [ fromMap citxScripts ScriptRow , fromMap citxRedeemers ScriptRow ] , txRows = fromPairs (const [(_citxTxId tx, tx)]) TxRow diff --git a/plutus-chain-index/src/Plutus/ChainIndex/Tx.hs b/plutus-chain-index/src/Plutus/ChainIndex/Tx.hs index 17e1759a2c6..8f789414967 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/Tx.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/Tx.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -24,9 +25,7 @@ module Plutus.ChainIndex.Tx( , citxValidRange , citxData , citxRedeemers - , citxMintingPolicies - , citxStakeValidators - , citxValidators + , citxScripts , citxCardanoTx , _InvalidTx , _ValidTx @@ -42,10 +41,11 @@ import qualified Data.Set as Set import Data.Text.Prettyprint.Doc import Data.Tuple (swap) import GHC.Generics (Generic) -import Ledger (Address, Datum, DatumHash, MintingPolicy, MintingPolicyHash, OnChainTx (..), - Redeemer (..), RedeemerHash, SlotRange, SomeCardanoApiTx, StakeValidator, - StakeValidatorHash, Tx (..), TxId, TxIn (txInType), TxInType (..), - TxOut (txOutAddress), TxOutRef (..), Validator, ValidatorHash, datumHash, +import Ledger (Address, Datum, DatumHash, MintingPolicy (getMintingPolicy), + MintingPolicyHash (MintingPolicyHash), OnChainTx (..), Redeemer (..), + RedeemerHash, Script, ScriptHash (..), SlotRange, SomeCardanoApiTx, Tx (..), + TxId, TxIn (txInType), TxInType (..), TxOut (txOutAddress), TxOutRef (..), + Validator (getValidator), ValidatorHash (ValidatorHash), datumHash, mintingPolicyHash, redeemerHash, txId, validatorHash) -- | List of outputs of a transaction. There are no outputs if the transaction @@ -58,44 +58,45 @@ data ChainIndexTxOutputs = makePrisms ''ChainIndexTxOutputs data ChainIndexTx = ChainIndexTx { - _citxTxId :: TxId, + _citxTxId :: TxId, -- ^ The id of this transaction. - _citxInputs :: Set TxIn, + _citxInputs :: Set TxIn, -- ^ The inputs to this transaction. - _citxOutputs :: ChainIndexTxOutputs, + _citxOutputs :: ChainIndexTxOutputs, -- ^ The outputs of this transaction, ordered so they can be referenced by index. - _citxValidRange :: !SlotRange, + _citxValidRange :: !SlotRange, -- ^ The 'SlotRange' during which this transaction may be validated. - _citxData :: Map DatumHash Datum, + _citxData :: Map DatumHash Datum, -- ^ Datum objects recorded on this transaction. - _citxRedeemers :: Map RedeemerHash Redeemer, + _citxRedeemers :: Map RedeemerHash Redeemer, -- ^ Redeemers of the minting scripts. - _citxMintingPolicies :: Map MintingPolicyHash MintingPolicy, - -- ^ The scripts used to check minting conditions. - _citxStakeValidators :: Map StakeValidatorHash StakeValidator, - _citxValidators :: Map ValidatorHash Validator, - _citxCardanoTx :: Maybe SomeCardanoApiTx -- Might be Nothing if we are in the emulator + _citxScripts :: Map ScriptHash Script, + -- ^ The scripts (validator, stake validator or minting) part of cardano tx. + _citxCardanoTx :: Maybe SomeCardanoApiTx + -- ^ The full Cardano API tx which was used to populate the rest of the + -- 'ChainIndexTx' fields. Useful because 'ChainIndexTx' doesn't have all the + -- details of the tx, so we keep it as a safety net. Might be Nothing if we + -- are in the emulator. } deriving (Show, Eq, Generic, ToJSON, FromJSON, Serialise) makeLenses ''ChainIndexTx - instance Pretty ChainIndexTx where - pretty ChainIndexTx{_citxTxId, _citxInputs, _citxOutputs = ValidTx outputs, _citxValidRange, _citxMintingPolicies, _citxData, _citxRedeemers} = + pretty ChainIndexTx{_citxTxId, _citxInputs, _citxOutputs = ValidTx outputs, _citxValidRange, _citxData, _citxRedeemers, _citxScripts} = let lines' = [ hang 2 (vsep ("inputs:" : fmap pretty (Set.toList _citxInputs))) , hang 2 (vsep ("outputs:" : fmap pretty outputs)) - , hang 2 (vsep ("minting policies:": fmap (pretty . fst) (Map.toList _citxMintingPolicies))) + , hang 2 (vsep ("scripts hashes:": fmap (pretty . fst) (Map.toList _citxScripts))) , "validity range:" <+> viaShow _citxValidRange , hang 2 (vsep ("data:": fmap (pretty . snd) (Map.toList _citxData) )) , hang 2 (vsep ("redeemers:": fmap (pretty . snd) (Map.toList _citxRedeemers) )) ] in nest 2 $ vsep ["Valid tx" <+> pretty _citxTxId <> colon, braces (vsep lines')] - pretty ChainIndexTx{_citxTxId, _citxInputs, _citxOutputs = InvalidTx, _citxValidRange, _citxMintingPolicies, _citxData, _citxRedeemers} = + pretty ChainIndexTx{_citxTxId, _citxInputs, _citxOutputs = InvalidTx, _citxValidRange, _citxData, _citxRedeemers, _citxScripts} = let lines' = [ hang 2 (vsep ("inputs:" : fmap pretty (Set.toList _citxInputs))) , hang 2 (vsep ["no outputs:"]) - , hang 2 (vsep ("minting policies:": fmap (pretty . fst) (Map.toList _citxMintingPolicies))) + , hang 2 (vsep ("scripts hashes:": fmap (pretty . fst) (Map.toList _citxScripts))) , "validity range:" <+> viaShow _citxValidRange , hang 2 (vsep ("data:": fmap (pretty . snd) (Map.toList _citxData) )) , hang 2 (vsep ("redeemers:": fmap (pretty . snd) (Map.toList _citxRedeemers) )) @@ -137,9 +138,7 @@ fromOnChainTx = \case , _citxValidRange = txValidRange , _citxData = txData <> otherDataHashes , _citxRedeemers = redeemers - , _citxMintingPolicies = mintingPolicies txMintScripts - , _citxStakeValidators = mempty - , _citxValidators = validatorHashes + , _citxScripts = mintingPolicies txMintScripts <> validatorHashes , _citxCardanoTx = Nothing } Invalid tx@Tx{txCollateral, txValidRange, txData, txInputs, txMintScripts} -> @@ -151,23 +150,23 @@ fromOnChainTx = \case , _citxValidRange = txValidRange , _citxData = txData <> otherDataHashes , _citxRedeemers = redeemers - , _citxMintingPolicies = mintingPolicies txMintScripts - , _citxStakeValidators = mempty - , _citxValidators = validatorHashes + , _citxScripts = mintingPolicies txMintScripts <> validatorHashes , _citxCardanoTx = Nothing } -mintingPolicies :: Set MintingPolicy -> Map MintingPolicyHash MintingPolicy -mintingPolicies = - let withHash mps = (mintingPolicyHash mps, mps) in - Map.fromList . fmap withHash . Set.toList +mintingPolicies :: Set MintingPolicy -> Map ScriptHash Script +mintingPolicies = Map.fromList . fmap withHash . Set.toList + where + withHash mp = let (MintingPolicyHash mph) = mintingPolicyHash mp + in (ScriptHash mph, getMintingPolicy mp) -validators :: Set TxIn -> (Map ValidatorHash Validator, Map DatumHash Datum, Map RedeemerHash Redeemer) -validators = - let withHash (ConsumeScriptAddress val red dat) = - ( Map.singleton (validatorHash val) val - , Map.singleton (datumHash dat) dat - , Map.singleton (redeemerHash red) red - ) - withHash _ = mempty - in foldMap (maybe mempty withHash . txInType) . Set.toList +validators :: Set TxIn -> (Map ScriptHash Script, Map DatumHash Datum, Map RedeemerHash Redeemer) +validators = foldMap (maybe mempty withHash . txInType) . Set.toList + where + withHash (ConsumeScriptAddress val red dat) = + let (ValidatorHash vh) = validatorHash val + in ( Map.singleton (ScriptHash vh) (getValidator val) + , Map.singleton (datumHash dat) dat + , Map.singleton (redeemerHash red) red + ) + withHash _ = mempty diff --git a/plutus-chain-index/src/Plutus/ChainIndex/TxIdState.hs b/plutus-chain-index/src/Plutus/ChainIndex/TxIdState.hs index cf5473e162b..efabece05fd 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/TxIdState.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/TxIdState.hs @@ -1,14 +1,10 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} module Plutus.ChainIndex.TxIdState( @@ -73,7 +69,7 @@ transactionStatus currentBlock txIdState txId else if isCommitted block' -- Illegal - We can't roll this transaction back. then Left $ InvalidRollbackAttempt currentBlock txId txIdState - else Right $ Unknown + else Right Unknown _ -> Left $ TxIdStateInvalid currentBlock txId txIdState where diff --git a/plutus-chain-index/src/Plutus/ChainIndex/UtxoState.hs b/plutus-chain-index/src/Plutus/ChainIndex/UtxoState.hs index 049d05ae813..24d861f541e 100644 --- a/plutus-chain-index/src/Plutus/ChainIndex/UtxoState.hs +++ b/plutus-chain-index/src/Plutus/ChainIndex/UtxoState.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/plutus-chain-index/src/Plutus/Contract/CardanoAPI.hs b/plutus-chain-index/src/Plutus/Contract/CardanoAPI.hs index b82517b1466..6c5b2153634 100644 --- a/plutus-chain-index/src/Plutus/Contract/CardanoAPI.hs +++ b/plutus-chain-index/src/Plutus/Contract/CardanoAPI.hs @@ -41,53 +41,150 @@ module Plutus.Contract.CardanoAPI( , FromCardanoError(..) ) where -import qualified Cardano.Api as C -import qualified Cardano.Api.Byron as C -import qualified Cardano.Api.Shelley as C -import Cardano.BM.Data.Tracer (ToObject (..)) -import Cardano.Chain.Common (addrToBase58) -import qualified Codec.Serialise as Codec -import Data.Aeson (FromJSON, ToJSON) -import Data.Bifunctor (first) -import Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.ByteString.Short as BSS -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Text.Prettyprint.Doc (Pretty (..), colon, (<+>)) -import GHC.Generics (Generic) -import qualified Ledger as P -import qualified Ledger.Ada as Ada -import Plutus.ChainIndex.Tx (ChainIndexTx (..)) -import qualified Plutus.ChainIndex.Tx as ChainIndex.Tx -import Plutus.Contract.CardanoAPITemp (makeTransactionBody') -import qualified Plutus.V1.Ledger.Api as Api -import qualified Plutus.V1.Ledger.Credential as Credential -import qualified Plutus.V1.Ledger.Value as Value -import qualified PlutusCore.Data as Data -import qualified PlutusTx.Prelude as PlutusTx +import qualified Cardano.Api as C +import qualified Cardano.Api.Byron as C +import qualified Cardano.Api.Shelley as C +import Cardano.BM.Data.Tracer (ToObject (..)) +import Cardano.Chain.Common (addrToBase58) +import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import qualified Cardano.Ledger.Alonzo.TxWitness as C +import qualified Cardano.Ledger.Core as Ledger +import Codec.Serialise (deserialiseOrFail) +import qualified Codec.Serialise as Codec +import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor (first) +import Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Short as BSS +import qualified Data.ByteString.Short as SBS +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Data.Text.Prettyprint.Doc (Pretty (..), colon, (<+>)) +import GHC.Generics (Generic) +import Ledger (SomeCardanoApiTx (SomeTx)) +import qualified Ledger as P +import qualified Ledger.Ada as Ada +import Plutus.ChainIndex.Tx (ChainIndexTx (..)) +import qualified Plutus.ChainIndex.Tx as ChainIndex.Tx +import Plutus.Contract.CardanoAPITemp (makeTransactionBody') +import qualified Plutus.V1.Ledger.Api as Api +import qualified Plutus.V1.Ledger.Credential as Credential +import qualified Plutus.V1.Ledger.Value as Value +import qualified PlutusCore.Data as Data +import qualified PlutusTx.Prelude as PlutusTx fromCardanoBlock :: C.BlockInMode C.CardanoMode -> Either FromCardanoError [ChainIndexTx] -fromCardanoBlock (C.BlockInMode (C.Block (C.BlockHeader _ _ _) txs) era) = - traverse (fromCardanoTx era) txs - -fromCardanoTx ::C.EraInMode era C.CardanoMode -> C.Tx era -> Either FromCardanoError ChainIndexTx -fromCardanoTx _era (C.Tx b@(C.TxBody C.TxBodyContent{..}) _keyWitnesses) = do +fromCardanoBlock (C.BlockInMode (C.Block C.BlockHeader {} txs) eraInMode) = + case eraInMode of + -- Unfortunately, we need to pattern match again all eras because + -- 'fromCardanoTx' has the constraints 'C.IsCardanoEra era', but not + -- 'C.BlockInMode'. + C.ByronEraInCardanoMode -> traverse (fromCardanoTx eraInMode) txs + C.ShelleyEraInCardanoMode -> traverse (fromCardanoTx eraInMode) txs + C.AllegraEraInCardanoMode -> traverse (fromCardanoTx eraInMode) txs + C.MaryEraInCardanoMode -> traverse (fromCardanoTx eraInMode) txs + C.AlonzoEraInCardanoMode -> traverse (fromCardanoTx eraInMode) txs + +-- | Convert a Cardano API tx of any given era to a Plutus chain index tx. +fromCardanoTx + :: C.IsCardanoEra era + => C.EraInMode era C.CardanoMode + -> C.Tx era + -> Either FromCardanoError ChainIndexTx +fromCardanoTx eraInMode tx@(C.Tx txBody@(C.TxBody C.TxBodyContent{..}) _) = do txOutputs <- traverse fromCardanoTxOut txOuts - pure - ChainIndexTx - { _citxTxId = fromCardanoTxId (C.getTxId b) + let scriptMap = plutusScriptsFromTxBody txBody + isTxScriptValid = fromTxScriptValidity txScriptValidity + (datums, redeemers) = scriptDataFromCardanoTxBody txBody + inputs = + if isTxScriptValid + then fst <$> txIns + else case txInsCollateral of + C.TxInsCollateralNone -> [] + C.TxInsCollateral _ txins -> txins + + pure ChainIndexTx + { _citxTxId = fromCardanoTxId (C.getTxId txBody) , _citxValidRange = fromCardanoValidityRange txValidityRange - , _citxInputs = Set.fromList $ fmap ((`P.TxIn` Nothing) . fromCardanoTxIn . fst) txIns - , _citxOutputs = ChainIndex.Tx.ValidTx txOutputs -- FIXME: Check if tx is invalid - , _citxData = mempty -- only available with a Build Tx - , _citxRedeemers = mempty -- only available with a Build Tx - , _citxMintingPolicies = mempty -- only available with a Build Tx - , _citxStakeValidators = mempty -- only available with a Build Tx - , _citxValidators = mempty -- only available with a Build Tx - , _citxCardanoTx = Nothing -- FIXME: Should be SomeTx t era, but we are missing a 'C.IsCardanoEra era' constraint. This constraint is required in 'Ledger.Tx' for the JSON instance. + -- If the transaction is invalid, we use collateral inputs + , _citxInputs = Set.fromList $ fmap ((`P.TxIn` Nothing) . fromCardanoTxIn) inputs + -- No outputs if the one of scripts failed + , _citxOutputs = if isTxScriptValid then ChainIndex.Tx.ValidTx txOutputs + else ChainIndex.Tx.InvalidTx + , _citxData = datums + , _citxRedeemers = redeemers + , _citxScripts = scriptMap + , _citxCardanoTx = Just $ SomeTx tx eraInMode } +-- | 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.TxScriptValidityNone = True +fromTxScriptValidity (C.TxScriptValidity C.TxScriptValiditySupportedInAlonzoEra C.ScriptValid) = True +fromTxScriptValidity (C.TxScriptValidity C.TxScriptValiditySupportedInAlonzoEra C.ScriptInvalid) = False + +-- | Given a 'C.TxBody from a 'C.Tx era', return the datums and redeemers along +-- with their hashes. +scriptDataFromCardanoTxBody + :: C.TxBody era + -> (Map P.DatumHash P.Datum, Map P.RedeemerHash P.Redeemer) +scriptDataFromCardanoTxBody C.ByronTxBody {} = (mempty, mempty) +scriptDataFromCardanoTxBody (C.ShelleyTxBody _ _ _ C.TxBodyNoScriptData _ _) = + (mempty, mempty) +scriptDataFromCardanoTxBody + (C.ShelleyTxBody _ _ _ (C.TxBodyScriptData _ (C.TxDats' dats) (C.Redeemers' reds)) _ _) = + + let datums = Map.fromList + $ fmap ( (\d -> (P.datumHash d, d)) + . P.Datum + . fromCardanoScriptData + . C.fromAlonzoData + ) + $ Map.elems dats + redeemers = Map.fromList + $ fmap ( (\r -> (P.redeemerHash r, r)) + . P.Redeemer + . fromCardanoScriptData + . C.fromAlonzoData + . fst + ) + $ Map.elems reds + in (datums, redeemers) + +-- | 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.Script +plutusScriptsFromTxBody C.ByronTxBody {} = mempty +plutusScriptsFromTxBody (C.ShelleyTxBody shelleyBasedEra _ scripts _ _ _) = + Map.fromList $ mapMaybe (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.ScriptHash, P.Script) +fromLedgerScript C.ShelleyBasedEraShelley _ = Nothing +fromLedgerScript C.ShelleyBasedEraAllegra _ = Nothing +fromLedgerScript C.ShelleyBasedEraMary _ = Nothing +fromLedgerScript C.ShelleyBasedEraAlonzo script = fromAlonzoLedgerScript script + +-- | Convert a script the Alonzo era to a Plutus script along with it's hash. +fromAlonzoLedgerScript :: Alonzo.Script a -> Maybe (P.ScriptHash, P.Script) +fromAlonzoLedgerScript Alonzo.TimelockScript {} = Nothing +fromAlonzoLedgerScript (Alonzo.PlutusScript bs) = + let script = fmap (\s -> (P.scriptHash s, s)) + $ deserialiseOrFail + $ BSL.fromStrict + $ SBS.fromShort bs + in either (const Nothing) Just script + toCardanoTxBody :: Maybe C.ProtocolParameters -- ^ Protocol parameters to use. Building Plutus transactions will fail if this is 'Nothing' -> C.NetworkId -- ^ Network ID diff --git a/plutus-chain-index/test/Generators.hs b/plutus-chain-index/test/Generators.hs index 4b5e4cbc112..2b69bfdc94e 100644 --- a/plutus-chain-index/test/Generators.hs +++ b/plutus-chain-index/test/Generators.hs @@ -190,8 +190,6 @@ genTx = do <*> pure mempty <*> pure mempty <*> pure mempty - <*> pure mempty - <*> pure mempty -- TODO: We need a way to convert the generated 'ChainIndexTx' to a -- 'SomeCardanoTx', or vis-versa. And then put it here. @@ -212,8 +210,6 @@ genTxIdStateTx = do <*> pure mempty <*> pure mempty <*> pure mempty - <*> pure mempty - <*> pure mempty <*> pure Nothing modify (over txgsBlocks ((:) [txId])) diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs index 29bb3010abc..859ef46b641 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs @@ -50,6 +50,7 @@ module Plutus.V1.Ledger.Scripts( -- * Hashes DatumHash(..), RedeemerHash(..), + ScriptHash(..), ValidatorHash(..), MintingPolicyHash (..), StakeValidatorHash (..), @@ -222,8 +223,8 @@ instance FromJSON Script where (SerialiseViaFlat p) <- JSON.decodeSerialise v Haskell.return $ Script p -deriving via (JSON.JSONViaSerialise PLC.Data) instance ToJSON (PLC.Data) -deriving via (JSON.JSONViaSerialise PLC.Data) instance FromJSON (PLC.Data) +deriving via (JSON.JSONViaSerialise PLC.Data) instance ToJSON PLC.Data +deriving via (JSON.JSONViaSerialise PLC.Data) instance FromJSON PLC.Data mkValidatorScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> Validator mkValidatorScript = Validator . fromCompiledCode @@ -316,6 +317,14 @@ instance BA.ByteArrayAccess StakeValidator where withByteArray = BA.withByteArray . BSL.toStrict . serialise +-- | Script runtime representation of a @Digest SHA256@. +newtype ScriptHash = + ScriptHash { getScriptHash :: Builtins.BuiltinByteString } + deriving (IsString, Haskell.Show, Serialise, Pretty) via LedgerBytes + deriving stock (Generic) + deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, Hashable, ToData, FromData, UnsafeFromData) + deriving anyclass (FromJSON, ToJSON, ToJSONKey, FromJSONKey, NFData) + -- | Script runtime representation of a @Digest SHA256@. newtype ValidatorHash = ValidatorHash Builtins.BuiltinByteString diff --git a/plutus-ledger/src/Ledger/Scripts.hs b/plutus-ledger/src/Ledger/Scripts.hs index d8926345f23..1ae7b1a1eea 100644 --- a/plutus-ledger/src/Ledger/Scripts.hs +++ b/plutus-ledger/src/Ledger/Scripts.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -89,13 +88,13 @@ redeemerHash :: Redeemer -> RedeemerHash redeemerHash = RedeemerHash . dataHash . getRedeemer validatorHash :: Validator -> ValidatorHash -validatorHash = ValidatorHash . scriptHash . getValidator +validatorHash = ValidatorHash . getScriptHash . scriptHash . getValidator mintingPolicyHash :: MintingPolicy -> MintingPolicyHash -mintingPolicyHash = MintingPolicyHash . scriptHash . getMintingPolicy +mintingPolicyHash = MintingPolicyHash . getScriptHash . scriptHash . getMintingPolicy stakeValidatorHash :: StakeValidator -> StakeValidatorHash -stakeValidatorHash = StakeValidatorHash . scriptHash . getStakeValidator +stakeValidatorHash = StakeValidatorHash . getScriptHash . scriptHash . getStakeValidator -- | Hash a 'Builtins.BuiltinData' dataHash :: Builtins.BuiltinData -> Builtins.BuiltinByteString @@ -107,9 +106,10 @@ dataHash = . builtinDataToData -- | Hash a 'Script' -scriptHash :: Script -> Builtins.BuiltinByteString +scriptHash :: Script -> ScriptHash scriptHash = - toBuiltin + ScriptHash + . toBuiltin . Script.serialiseToRawBytes . Script.hashScript . toCardanoApiScript