SCP-2753: Extract datums, redeemers and scripts when converting carda…

…no api tx to plutus tx.

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

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

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,

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
         }

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,20 @@ 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           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.ChainIndexError    (ChainIndexError (..))
 import           Plutus.ChainIndex.ChainIndexLog      (ChainIndexLog (..))
 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 +95,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 +115,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

plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs

@@ -1,12 +1,10 @@
-{-# LANGUAGE ExplicitNamespaces    #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# 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

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