Fix marlowe-chain-sync redeemer extraction

marlowe-chain-sync/marlowe-chain-sync.cabal

@@ -97,6 +97,7 @@ library
     , hashable >=1.3 && <2
     , hs-opentelemetry-api ^>=0.0.3
     , marlowe-protocols ==0.3.0.0
+    , microlens
     , nonempty-containers ^>=0.3.4
     , ouroboros-consensus ^>=0.20
     , ouroboros-consensus-cardano ^>=0.18

marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Alonzo.hs

@@ -7,7 +7,6 @@ module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo where
 
 import Cardano.Binary (serialize')
 import Cardano.Ledger.Allegra.Core (
-  EraTx (Tx),
   EraTxAuxData (TxAuxData),
   ValidityInterval,
  )
@@ -17,24 +16,41 @@ import Cardano.Ledger.Alonzo (
   AlonzoTxAuxData,
   AlonzoTxOut,
  )
-import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), txdats')
+import Cardano.Ledger.Alonzo.Core (
+  AlonzoEraTxWits (rdmrsTxWitsL),
+  AsIxItem (..),
+  Era (EraCrypto),
+  EraTxBody,
+  PlutusPurpose,
+  inputsTxBodyL,
+ )
+import Cardano.Ledger.Alonzo.Scripts (
+  AlonzoEraScript (hoistPlutusPurpose),
+  AlonzoPlutusPurpose (AlonzoSpending),
+  toAsIx,
+ )
+import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..), bodyAlonzoTxL, witsAlonzoTxL)
 import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
 import Cardano.Ledger.Alonzo.TxBody (AlonzoTxBody (..), AlonzoTxOut (..))
-import Cardano.Ledger.Alonzo.TxWits (TxDats)
+import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), TxDats, lookupRedeemer)
 import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo
+import Cardano.Ledger.Alonzo.UTxO (zipAsIxItem)
 import Cardano.Ledger.BaseTypes (shelleyProtVer)
 import qualified Cardano.Ledger.Binary as L
 import Cardano.Ledger.Crypto (StandardCrypto)
+import Cardano.Ledger.Plutus (dataToBinaryData)
 import Cardano.Ledger.Shelley.API (
   ScriptHash (..),
   ShelleyTxOut (ShelleyTxOut),
   StrictMaybe,
   TxIn,
  )
+import Control.Monad (join)
 import Data.ByteString (ByteString)
 import Data.Foldable (Foldable (..))
 import Data.Int (Int16, Int64)
 import qualified Data.Map as Map
+import Data.Maybe (listToMaybe)
 import qualified Data.Set as Set
 import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows, maryTxOutRow, maryTxRow)
 import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (
@@ -55,6 +71,7 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types (
   TxRowGroup,
  )
 import qualified Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types as Marlowe
+import Lens.Micro ((^.))
 
 alonzoTxToRows :: Int64 -> Bytea -> Bytea -> AlonzoTx (AlonzoEra StandardCrypto) -> TxRowGroup
 alonzoTxToRows slotNo blockHash txId tx@AlonzoTx{..} =
@@ -96,10 +113,15 @@ convertIsValid :: IsValid -> SqlBool
 convertIsValid (IsValid b) = SqlBool b
 
 alonzoTxInRows
-  :: Int64
+  :: forall era
+   . (AlonzoEraTxWits era)
+  => (StandardCrypto ~ EraCrypto era)
+  => (PlutusPurpose AsIxItem era ~ AlonzoPlutusPurpose AsIxItem era)
+  => (EraTxBody era)
+  => Int64
   -> Bytea
   -> IsValid
-  -> Tx era
+  -> AlonzoTx era
   -> Set.Set (TxIn StandardCrypto)
   -> Set.Set (TxIn StandardCrypto)
   -> [TxInRow]
@@ -110,12 +132,27 @@ alonzoTxInRows slot txId (IsValid isValid) tx inputs collateralInputs
       pure TxInRow{isCollateral = SqlBool True, ..}
 
 alonzoTxInRow
-  :: Int64
+  :: forall era
+   . (AlonzoEraTxWits era)
+  => (StandardCrypto ~ EraCrypto era)
+  => (PlutusPurpose AsIxItem era ~ AlonzoPlutusPurpose AsIxItem era)
+  => (EraTxBody era)
+  => Int64
   -> Bytea
-  -> Tx era
-  -> TxIn StandardCrypto
+  -> AlonzoTx era
+  -> TxIn (EraCrypto era)
   -> TxInRow
-alonzoTxInRow slotNo txInId _ = shelleyTxInRow slotNo txInId
+alonzoTxInRow slotNo txInId tx txIn =
+  (shelleyTxInRow slotNo txInId txIn)
+    { redeemerDatumBytes = do
+        let redeemers = tx ^. witsAlonzoTxL . rdmrsTxWitsL
+            inputs = tx ^. bodyAlonzoTxL . inputsTxBodyL
+        index <- listToMaybe $ join $ zipAsIxItem (Set.toList inputs) $ \asIxItem@(AsIxItem _ txIn') ->
+          [asIxItem | txIn == txIn']
+        let purpose = AlonzoSpending @AsIxItem @era index
+        (datum, _) <- lookupRedeemer (hoistPlutusPurpose toAsIx purpose) redeemers
+        pure $ originalBytea $ dataToBinaryData datum
+    }
 
 alonzoTxOutRow
   :: Int64

marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Database/PostgreSQL/Conway.hs

@@ -6,10 +6,11 @@
 module Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Conway where
 
 import Cardano.Ledger.Allegra.TxBody (StrictMaybe (..))
-import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..))
-
+import Cardano.Ledger.Alonzo.Scripts (toAsIx)
+import Cardano.Ledger.Alonzo.Tx (bodyAlonzoTxL, witsAlonzoTxL)
 import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
-import Cardano.Ledger.Alonzo.TxWits (TxDats (..))
+import Cardano.Ledger.Alonzo.TxWits (TxDats (..), lookupRedeemer)
+import Cardano.Ledger.Alonzo.UTxO (zipAsIxItem)
 import Cardano.Ledger.Babbage (BabbageEra, BabbageTxOut)
 import Cardano.Ledger.Babbage.Tx (
   IsValid (..),
@@ -18,26 +19,41 @@ import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
 import Cardano.Ledger.Binary (Sized (..), shelleyProtVer)
 import qualified Cardano.Ledger.Binary as L
 import Cardano.Ledger.Conway (ConwayEra)
-import Cardano.Ledger.Conway.Core (EraTx (Tx), hashScript)
+import Cardano.Ledger.Conway.Core (
+  AlonzoEraTxWits,
+  AsIxItem (..),
+  Era (EraCrypto),
+  EraTx,
+  EraTxBody (inputsTxBodyL),
+  PlutusPurpose,
+  hashScript,
+  hoistPlutusPurpose,
+ )
 import Cardano.Ledger.Conway.Scripts (
   AlonzoScript (..),
+  ConwayPlutusPurpose (ConwaySpending),
  )
+import Cardano.Ledger.Conway.Tx (AlonzoTx (..))
 import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..))
-import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..))
+import Cardano.Ledger.Conway.TxWits (AlonzoEraTxWits (rdmrsTxWitsL), AlonzoTxWits (..))
 import Cardano.Ledger.Core (ScriptHash (..))
 import Cardano.Ledger.Crypto (StandardCrypto)
+import Cardano.Ledger.Plutus.Data (dataToBinaryData)
 import Cardano.Ledger.Shelley.API (TxIn)
 import Control.Arrow (Arrow (..))
+import Control.Monad (join)
 import Data.ByteString (ByteString)
 import Data.Foldable (Foldable (..))
 import Data.Int (Int64)
 import qualified Data.Map as Map
+import Data.Maybe (listToMaybe)
 import qualified Data.Set as Set
 import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Alonzo (alonzoTxRow)
 import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Babbage (babbageTxOutRows)
 import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Mary (maryAssetMintRows)
 import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Shelley (
   hashToBytea,
+  originalBytea,
   serializeBytea,
   shelleyTxInRow,
  )
@@ -48,6 +64,7 @@ import Language.Marlowe.Runtime.ChainSync.Database.PostgreSQL.Types (
   TxInRow (..),
   TxRowGroup,
  )
+import Lens.Micro ((^.))
 import Unsafe.Coerce (unsafeCoerce)
 
 conwayTxToRows :: Int64 -> Bytea -> Bytea -> AlonzoTx (ConwayEra StandardCrypto) -> TxRowGroup
@@ -97,10 +114,15 @@ coerceDats :: TxDats (ConwayEra StandardCrypto) -> TxDats (BabbageEra StandardCr
 coerceDats = unsafeCoerce
 
 conwayTxInRows
-  :: Int64
+  :: forall era
+   . (EraTx era)
+  => (EraCrypto era ~ StandardCrypto)
+  => (PlutusPurpose AsIxItem era ~ ConwayPlutusPurpose AsIxItem era)
+  => (AlonzoEraTxWits era)
+  => Int64
   -> Bytea
   -> Cardano.Ledger.Babbage.Tx.IsValid
-  -> Tx era
+  -> AlonzoTx era
   -> Set.Set (TxIn StandardCrypto)
   -> Set.Set (TxIn StandardCrypto)
   -> [TxInRow]
@@ -111,9 +133,24 @@ conwayTxInRows slot txId (Cardano.Ledger.Babbage.Tx.IsValid isValid) tx inputs c
       pure TxInRow{isCollateral = SqlBool True, ..}
 
 conwayTxInRow
-  :: Int64
+  :: forall era
+   . (EraTx era)
+  => (EraCrypto era ~ StandardCrypto)
+  => (PlutusPurpose AsIxItem era ~ ConwayPlutusPurpose AsIxItem era)
+  => (AlonzoEraTxWits era)
+  => Int64
   -> Bytea
-  -> Tx era
+  -> AlonzoTx era
   -> TxIn StandardCrypto
   -> TxInRow
-conwayTxInRow slotNo txInId _ = shelleyTxInRow slotNo txInId
+conwayTxInRow slotNo txInId tx txIn =
+  (shelleyTxInRow slotNo txInId txIn)
+    { redeemerDatumBytes = do
+        let redeemers = tx ^. witsAlonzoTxL . rdmrsTxWitsL
+            inputs = tx ^. bodyAlonzoTxL . inputsTxBodyL
+        index <- listToMaybe $ join $ zipAsIxItem (Set.toList inputs) $ \asIxItem@(AsIxItem _ txIn') ->
+          [asIxItem | txIn == txIn']
+        let purpose = ConwaySpending @AsIxItem @era index
+        (datum, _) <- lookupRedeemer (hoistPlutusPurpose toAsIx purpose) redeemers
+        pure $ originalBytea $ dataToBinaryData datum
+    }