translate the redeemers for plutus context

alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs

@@ -52,6 +52,7 @@ module Cardano.Ledger.Alonzo.Tx
     -- Figure 6
     txrdmrs,
     rdptr,
+    rdptrInv,
     getMapFromValue,
     indexedRdmrs,
     -- Pretty
@@ -408,21 +409,31 @@ instance (Typeable c, CC.Crypto c) => FromCBOR (ScriptPurpose c) where
 
 class Indexable elem container where
   indexOf :: elem -> container -> StrictMaybe Word64
+  fromIndex :: Word64 -> container -> StrictMaybe elem
 
 instance Ord k => Indexable k (Set k) where
   indexOf n set = case Set.lookupIndex n set of
     Just x -> SJust (fromIntegral x)
     Nothing -> SNothing
+  fromIndex i set =
+    if (fromIntegral i) < Set.size set
+      then SJust $ Set.elemAt (fromIntegral i) set
+      else SNothing
 
 instance Eq k => Indexable k (StrictSeq k) where
   indexOf n seqx = case StrictSeq.findIndexL (== n) seqx of
     Just m -> SJust (fromIntegral m)
     Nothing -> SNothing
+  fromIndex i seqx = maybeToStrictMaybe $ StrictSeq.lookup (fromIntegral i) seqx
 
 instance Ord k => Indexable k (Map.Map k v) where
   indexOf n mp = case Map.lookupIndex n mp of
     Just x -> SJust (fromIntegral x)
     Nothing -> SNothing
+  fromIndex i mp =
+    if (fromIntegral i) < Map.size mp
+      then SJust . fst $ Map.elemAt (fromIntegral i) mp
+      else SNothing
 
 rdptr ::
   forall era.
@@ -440,6 +451,25 @@ rdptr txb (Spending txin) = RdmrPtr Spend <$> indexOf txin (getField @"inputs" t
 rdptr txb (Rewarding racnt) = RdmrPtr Rewrd <$> indexOf racnt (unWdrl (getField @"wdrls" txb))
 rdptr txb (Certifying d) = RdmrPtr Cert <$> indexOf d (getField @"certs" txb)
 
+rdptrInv ::
+  forall era.
+  ( HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
+    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
+    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
+    HasField "minted" (Core.TxBody era) (Set (ScriptHash (Crypto era)))
+  ) =>
+  Core.TxBody era ->
+  RdmrPtr ->
+  StrictMaybe (ScriptPurpose (Crypto era))
+rdptrInv txb (RdmrPtr Mint idx) =
+  (Minting . PolicyID) <$> fromIndex idx (getField @"minted" txb)
+rdptrInv txb (RdmrPtr Spend idx) =
+  Spending <$> fromIndex idx (getField @"inputs" txb)
+rdptrInv txb (RdmrPtr Rewrd idx) =
+  Rewarding <$> fromIndex idx (unWdrl (getField @"wdrls" txb))
+rdptrInv txb (RdmrPtr Cert idx) =
+  Certifying <$> fromIndex idx (getField @"certs" txb)
+
 getMapFromValue :: Value crypto -> Map.Map (PolicyID crypto) (Map.Map AssetName Integer)
 getMapFromValue (Value _ m) = m
 

alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs

@@ -29,7 +29,7 @@ import Cardano.Ledger.Alonzo.TxBody
     wdrls',
   )
 import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..))
-import Cardano.Ledger.Alonzo.TxWitness (TxWitness, unTxDats)
+import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr, TxWitness (..), unRedeemers, unTxDats)
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core as Core (TxBody, TxOut, Value)
@@ -62,8 +62,9 @@ import Data.Coders
 import Data.Fixed (HasResolution (resolution))
 import qualified Data.Map as Map
 import Data.Maybe (mapMaybe)
+import Data.Sequence.Strict (StrictSeq)
+import Data.Set (Set)
 import qualified Data.Set as Set
--- Instances only
 import Data.Text (Text, pack)
 import Data.Text.Prettyprint.Doc (Pretty (..))
 import Data.Time.Clock (nominalDiffTimeToSeconds)
@@ -73,50 +74,6 @@ import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
 import qualified Plutus.V1.Ledger.Api as P
-  ( Address (..),
-    BuiltinByteString,
-    Credential (..),
-    CurrencySymbol (..),
-    DCert (..),
-    Data (..),
-    Datum (..),
-    DatumHash (..),
-    EvaluationError (..),
-    ExBudget (..),
-    ExCPU (..),
-    ExMemory (..),
-    Interval (..),
-    POSIXTime (..),
-    POSIXTimeRange,
-    PubKeyHash (..),
-    ScriptContext (..),
-    ScriptPurpose (..),
-    StakingCredential (..),
-    TokenName (..),
-    TxId (..),
-    TxInInfo (..),
-    TxInfo (..),
-    TxOut (..),
-    TxOutRef (..),
-    ValidatorHash (..),
-    Value (..),
-    VerboseMode (..),
-    adaSymbol,
-    adaToken,
-    always,
-    dataToBuiltinData,
-    evaluateScriptRestricting,
-    from,
-    fromData,
-    lowerBound,
-    singleton,
-    strictUpperBound,
-    to,
-    toBuiltin,
-    toData,
-    unionWith,
-    validateScript,
-  )
 import Plutus.V1.Ledger.Contexts ()
 import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
 import Shelley.Spec.Ledger.TxBody
@@ -315,6 +272,23 @@ getWitVKeyHash =
 transDataPair :: (DataHash c, Data era) -> (P.DatumHash, P.Datum)
 transDataPair (x, y) = (transDataHash' x, P.Datum (P.dataToBuiltinData (getPlutusData y)))
 
+transRedeemer :: Data era -> P.Redeemer
+transRedeemer = P.Redeemer . P.dataToBuiltinData . getPlutusData
+
+transRedeemerPtr ::
+  ( Era era,
+    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
+    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
+    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era)))
+  ) =>
+  (Core.TxBody era) ->
+  (RdmrPtr, (Data era, ExUnits)) ->
+  Maybe (P.ScriptPurpose, P.Redeemer)
+transRedeemerPtr txb (ptr, (d, _)) =
+  case rdptrInv txb ptr of
+    SNothing -> Nothing
+    SJust sp -> Just (transScriptPurpose sp, transRedeemer d)
+
 transExUnits :: ExUnits -> P.ExBudget
 transExUnits (ExUnits mem steps) =
   P.ExBudget (P.ExCPU (fromIntegral steps)) (P.ExMemory (fromIntegral mem))
@@ -370,8 +344,7 @@ txInfo ei sysS utxo tx = do
         P.txInfoWdrl = Map.toList (transWdrl (wdrls' tbody)),
         P.txInfoValidRange = timeRange,
         P.txInfoSignatories = map transKeyHash (Set.toList (reqSignerHashes' tbody)),
-        -- The type of txInfoRedeemers is [(ScriptPurpose, Redeemer)]
-        P.txInfoRedeemers = undefined,
+        P.txInfoRedeemers = mapMaybe (transRedeemerPtr tbody) rdmrs,
         P.txInfoData = map transDataPair datpairs,
         P.txInfoId = P.TxId (transSafeHash (hashAnnotated @(Crypto era) tbody))
       }
@@ -383,6 +356,7 @@ txInfo ei sysS utxo tx = do
     forge = mint' tbody
     interval = vldt' tbody
     datpairs = Map.toList (unTxDats $ txdats' _witnesses)
+    rdmrs = Map.toList (unRedeemers $ txrdmrs' _witnesses)
 
 -- ===============================================================
 -- From the specification, Figure 7 "Script Validation, cont."