module Hydra.Tx.Commit where

import Hydra.Cardano.Api
import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Core (AsIxItem (..))
import Cardano.Ledger.Api (
  AsIx (..),
  ConwayPlutusPurpose (..),
  Redeemers (..),
  bodyTxL,
  inputsTxBodyL,
  mintTxBodyL,
  outputsTxBodyL,
  rdmrsTxWitsL,
  redeemerPointerInverse,
  referenceInputsTxBodyL,
  reqSignerHashesTxBodyL,
  unRedeemers,
  witsTxL,
 )
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
import Control.Lens ((.~), (<>~), (^.))
import Data.Map qualified as Map
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Initial qualified as Initial
import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..))
import Hydra.Tx.HeadId (HeadId, headIdToCurrencySymbol, mkHeadId)
import Hydra.Tx.Party (Party, partyFromChain, partyToChain)
import Hydra.Tx.ScriptRegistry (ScriptRegistry, initialReference)
import Hydra.Tx.Utils (addMetadata, mkHydraHeadV1TxName)
import PlutusLedgerApi.V3 (CurrencySymbol)
import PlutusLedgerApi.V3 qualified as Plutus

-- * Construction

-- | Craft a commit transaction which includes the "committed" utxo as a datum.
commitTx ::
  NetworkId ->
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  HeadId ->
  Party ->
  CommitBlueprintTx Tx ->
  -- | The initial output (sent to each party) which should contain the PT and is
  -- locked by initial script
  (TxIn, TxOut CtxUTxO, Hash PaymentKey) ->
  Tx
commitTx :: NetworkId
-> ScriptRegistry
-> HeadId
-> Party
-> CommitBlueprintTx Tx
-> (TxIn, TxOut CtxUTxO, Hash PaymentKey)
-> Tx
commitTx NetworkId
networkId ScriptRegistry
scriptRegistry HeadId
headId Party
party CommitBlueprintTx Tx
commitBlueprintTx (TxIn
initialInput, TxOut CtxUTxO
out, Hash PaymentKey
vkh) =
  -- NOTE: We use the cardano-ledger-api functions here such that we can use the
  -- blueprint transaction as a starting point (cardano-api does not allow
  -- convenient transaction modifications).
  Tx LedgerEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx LedgerEra -> Tx) -> Tx LedgerEra -> Tx
forall a b. (a -> b) -> a -> b
$
    Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx
      Tx StandardConway
-> (Tx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& Tx StandardConway -> AlonzoTx StandardConway
spendFromInitial
      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((StrictSeq (TxOut StandardConway)
     -> Identity (StrictSeq (TxOut StandardConway)))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (StrictSeq (TxOut StandardConway)
    -> Identity (StrictSeq (TxOut StandardConway)))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut StandardConway)
 -> Identity (StrictSeq (TxOut StandardConway)))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardConway) (StrictSeq (TxOut StandardConway))
outputsTxBodyL ((StrictSeq (TxOut StandardConway)
  -> Identity (StrictSeq (TxOut StandardConway)))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> StrictSeq (TxOut StandardConway)
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut StandardConway -> StrictSeq (TxOut StandardConway)
forall a. a -> StrictSeq a
StrictSeq.singleton (TxOut CtxUTxO -> TxOut LedgerEra
forall era.
IsShelleyBasedEra era =>
TxOut CtxUTxO era -> TxOut (ShelleyLedgerEra era)
toLedgerTxOut TxOut CtxUTxO
commitOutput)
      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((MultiAsset (EraCrypto StandardConway)
     -> Identity (MultiAsset (EraCrypto StandardConway)))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (MultiAsset (EraCrypto StandardConway)
    -> Identity (MultiAsset (EraCrypto StandardConway)))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiAsset (EraCrypto StandardConway)
 -> Identity (MultiAsset (EraCrypto StandardConway)))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
Lens'
  (TxBody StandardConway) (MultiAsset (EraCrypto StandardConway))
mintTxBodyL ((MultiAsset (EraCrypto StandardConway)
  -> Identity (MultiAsset (EraCrypto StandardConway)))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> MultiAsset (EraCrypto StandardConway)
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset (EraCrypto StandardConway)
forall a. Monoid a => a
mempty
      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& TxMetadata
-> Tx -> AlonzoTx StandardConway -> AlonzoTx StandardConway
addMetadata (Text -> TxMetadata
mkHydraHeadV1TxName Text
"CommitTx") Tx
blueprintTx
 where
  spendFromInitial :: Tx StandardConway -> AlonzoTx StandardConway
spendFromInitial Tx StandardConway
tx =
    let newRedeemers :: Map (TxIn StandardCrypto) (Data StandardConway)
newRedeemers =
          Tx StandardConway
-> Map (TxIn (EraCrypto StandardConway)) (Data StandardConway)
forall {era} {era}.
(PlutusPurpose AsIxItem era ~ ConwayPlutusPurpose AsIxItem era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AlonzoEraTxBody era, EraTx era, AlonzoEraTxWits era,
 EraPParams era, Eq (TxCert era), Show (TxCert era),
 NFData (TxCert era), NoThunks (TxCert era)) =>
Tx era -> Map (TxIn (EraCrypto era)) (Data era)
resolveSpendingRedeemers Tx StandardConway
tx
            Map (TxIn StandardCrypto) (Data StandardConway)
-> (Map (TxIn StandardCrypto) (Data StandardConway)
    -> Map (TxIn StandardCrypto) (Data StandardConway))
-> Map (TxIn StandardCrypto) (Data StandardConway)
forall a b. a -> (a -> b) -> b
& TxIn StandardCrypto
-> Data StandardConway
-> Map (TxIn StandardCrypto) (Data StandardConway)
-> Map (TxIn StandardCrypto) (Data StandardConway)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TxIn -> TxIn StandardCrypto
toLedgerTxIn TxIn
initialInput) (forall era. Era era => HashableScriptData -> Data era
toLedgerData @LedgerEra HashableScriptData
initialRedeemer)
        newInputs :: Set (TxIn StandardCrypto)
newInputs = Tx StandardConway
tx Tx StandardConway
-> Getting
     (Set (TxIn StandardCrypto))
     (Tx StandardConway)
     (Set (TxIn StandardCrypto))
-> Set (TxIn StandardCrypto)
forall s a. s -> Getting a s a -> a
^. (TxBody StandardConway
 -> Const (Set (TxIn StandardCrypto)) (TxBody StandardConway))
-> Tx StandardConway
-> Const (Set (TxIn StandardCrypto)) (Tx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway
  -> Const (Set (TxIn StandardCrypto)) (TxBody StandardConway))
 -> Tx StandardConway
 -> Const (Set (TxIn StandardCrypto)) (Tx StandardConway))
-> ((Set (TxIn StandardCrypto)
     -> Const (Set (TxIn StandardCrypto)) (Set (TxIn StandardCrypto)))
    -> TxBody StandardConway
    -> Const (Set (TxIn StandardCrypto)) (TxBody StandardConway))
-> Getting
     (Set (TxIn StandardCrypto))
     (Tx StandardConway)
     (Set (TxIn StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (TxIn StandardCrypto)
 -> Const (Set (TxIn StandardCrypto)) (Set (TxIn StandardCrypto)))
-> TxBody StandardConway
-> Const (Set (TxIn StandardCrypto)) (TxBody StandardConway)
(Set (TxIn (EraCrypto StandardConway))
 -> Const
      (Set (TxIn StandardCrypto))
      (Set (TxIn (EraCrypto StandardConway))))
-> TxBody StandardConway
-> Const (Set (TxIn StandardCrypto)) (TxBody StandardConway)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardConway) (Set (TxIn (EraCrypto StandardConway)))
inputsTxBodyL Set (TxIn StandardCrypto)
-> Set (TxIn StandardCrypto) -> Set (TxIn StandardCrypto)
forall a. Semigroup a => a -> a -> a
<> TxIn StandardCrypto -> Set (TxIn StandardCrypto)
forall a. a -> Set a
Set.singleton (TxIn -> TxIn StandardCrypto
toLedgerTxIn TxIn
initialInput)
     in Tx StandardConway
tx
          Tx StandardConway
-> (Tx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> Tx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((Set (TxIn (EraCrypto StandardConway))
     -> Identity (Set (TxIn StandardCrypto)))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (Set (TxIn (EraCrypto StandardConway))
    -> Identity (Set (TxIn StandardCrypto)))
-> Tx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (TxIn (EraCrypto StandardConway))
 -> Identity (Set (TxIn StandardCrypto)))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
(Set (TxIn (EraCrypto StandardConway))
 -> Identity (Set (TxIn (EraCrypto StandardConway))))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardConway) (Set (TxIn (EraCrypto StandardConway)))
inputsTxBodyL ((Set (TxIn (EraCrypto StandardConway))
  -> Identity (Set (TxIn StandardCrypto)))
 -> Tx StandardConway -> Identity (AlonzoTx StandardConway))
-> Set (TxIn StandardCrypto)
-> Tx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (TxIn StandardCrypto)
newInputs
          AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((Set (TxIn StandardCrypto)
     -> Identity (Set (TxIn StandardCrypto)))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (Set (TxIn StandardCrypto)
    -> Identity (Set (TxIn StandardCrypto)))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (TxIn StandardCrypto) -> Identity (Set (TxIn StandardCrypto)))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
(Set (TxIn (EraCrypto StandardConway))
 -> Identity (Set (TxIn (EraCrypto StandardConway))))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardConway) (Set (TxIn (EraCrypto StandardConway)))
referenceInputsTxBodyL ((Set (TxIn StandardCrypto)
  -> Identity (Set (TxIn StandardCrypto)))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> Set (TxIn StandardCrypto)
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ TxIn StandardCrypto -> Set (TxIn StandardCrypto)
forall a. a -> Set a
Set.singleton (TxIn -> TxIn StandardCrypto
toLedgerTxIn TxIn
initialScriptRef)
          AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((Set (KeyHash 'Witness StandardCrypto)
     -> Identity (Set (KeyHash 'Witness StandardCrypto)))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (Set (KeyHash 'Witness StandardCrypto)
    -> Identity (Set (KeyHash 'Witness StandardCrypto)))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (KeyHash 'Witness StandardCrypto)
 -> Identity (Set (KeyHash 'Witness StandardCrypto)))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
(Set (KeyHash 'Witness (EraCrypto StandardConway))
 -> Identity (Set (KeyHash 'Witness (EraCrypto StandardConway))))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness (EraCrypto era)))
Lens'
  (TxBody StandardConway)
  (Set (KeyHash 'Witness (EraCrypto StandardConway)))
reqSignerHashesTxBodyL ((Set (KeyHash 'Witness StandardCrypto)
  -> Identity (Set (KeyHash 'Witness StandardCrypto)))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> Set (KeyHash 'Witness StandardCrypto)
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ KeyHash 'Witness StandardCrypto
-> Set (KeyHash 'Witness StandardCrypto)
forall a. a -> Set a
Set.singleton (Hash PaymentKey -> KeyHash 'Witness StandardCrypto
toLedgerKeyHash Hash PaymentKey
vkh)
          AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxWits StandardConway -> Identity (TxWits StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxWits StandardConway -> Identity (TxWits StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx StandardConway) (TxWits StandardConway)
witsTxL ((TxWits StandardConway -> Identity (TxWits StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((Redeemers StandardConway
     -> Identity (Redeemers StandardConway))
    -> TxWits StandardConway -> Identity (TxWits StandardConway))
-> (Redeemers StandardConway
    -> Identity (Redeemers StandardConway))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers StandardConway -> Identity (Redeemers StandardConway))
-> TxWits StandardConway -> Identity (TxWits StandardConway)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits StandardConway) (Redeemers StandardConway)
rdmrsTxWitsL
            ((Redeemers StandardConway -> Identity (Redeemers StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> Redeemers StandardConway
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map
  (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
-> Redeemers StandardConway
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers ([Item
   (Map
      (PlutusPurpose AsIx StandardConway)
      (Data StandardConway, ExUnits))]
-> Map
     (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
forall l. IsList l => [Item l] -> l
fromList ([Item
    (Map
       (PlutusPurpose AsIx StandardConway)
       (Data StandardConway, ExUnits))]
 -> Map
      (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits))
-> [Item
      (Map
         (PlutusPurpose AsIx StandardConway)
         (Data StandardConway, ExUnits))]
-> Map
     (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
forall a b. (a -> b) -> a -> b
$ Tx StandardConway
-> [(ConwayPlutusPurpose AsIx StandardConway,
     (Data StandardConway, ExUnits))]
forall {era} {era} {era}.
(PlutusPurpose AsIxItem era ~ ConwayPlutusPurpose AsIxItem era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AlonzoEraTxBody era, EraTx era, AlonzoEraTxWits era,
 EraPParams era, Eq (TxCert era), Show (TxCert era),
 NFData (TxCert era), NoThunks (TxCert era)) =>
Tx era -> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
nonSpendingRedeemers Tx StandardConway
tx)
              Redeemers StandardConway
-> Redeemers StandardConway -> Redeemers StandardConway
forall a. Semigroup a => a -> a -> a
<> Map
  (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
-> Redeemers StandardConway
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers ([Item
   (Map
      (PlutusPurpose AsIx StandardConway)
      (Data StandardConway, ExUnits))]
-> Map
     (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
forall l. IsList l => [Item l] -> l
fromList ([Item
    (Map
       (PlutusPurpose AsIx StandardConway)
       (Data StandardConway, ExUnits))]
 -> Map
      (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits))
-> [Item
      (Map
         (PlutusPurpose AsIx StandardConway)
         (Data StandardConway, ExUnits))]
-> Map
     (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
forall a b. (a -> b) -> a -> b
$ Map (TxIn StandardCrypto) (Data StandardConway)
-> Set (TxIn StandardCrypto)
-> [(ConwayPlutusPurpose AsIx StandardConway,
     (Data StandardConway, ExUnits))]
forall {k} {a} {era}.
Ord k =>
Map k a -> Set k -> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
mkRedeemers Map (TxIn StandardCrypto) (Data StandardConway)
newRedeemers Set (TxIn StandardCrypto)
newInputs)

  -- Make redeemers (with zeroed units) from a TxIn -> Data map and a set of transaction inputs
  mkRedeemers :: Map k a -> Set k -> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
mkRedeemers Map k a
resolved Set k
inputs =
    ([(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
 -> k -> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))])
-> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
-> Set k
-> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
      ( \[(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
newRedeemerData k
txin ->
          let ix :: Word32
ix = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ k -> Set k -> Int
forall a. Ord a => a -> Set a -> Int
Set.findIndex k
txin Set k
inputs
           in case k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
txin Map k a
resolved of
                Maybe a
Nothing -> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
newRedeemerData
                Just a
d ->
                  (AsIx Word32 (TxIn (EraCrypto era)) -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> ConwayPlutusPurpose f era
ConwaySpending (Word32 -> AsIx Word32 (TxIn (EraCrypto era))
forall ix it. ix -> AsIx ix it
AsIx Word32
ix), (a
d, Nat -> Nat -> ExUnits
ExUnits Nat
0 Nat
0)) (ConwayPlutusPurpose AsIx era, (a, ExUnits))
-> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
-> [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
forall a. a -> [a] -> [a]
: [(ConwayPlutusPurpose AsIx era, (a, ExUnits))]
newRedeemerData
      )
      []
      Set k
inputs

  -- Create a TxIn -> Data map of all spending redeemers
  resolveSpendingRedeemers :: Tx era -> Map (TxIn (EraCrypto era)) (Data era)
resolveSpendingRedeemers Tx era
tx =
    (PlutusPurpose AsIx era
 -> (Data era, ExUnits) -> Map (TxIn (EraCrypto era)) (Data era))
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (TxIn (EraCrypto era)) (Data era)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
      ( \PlutusPurpose AsIx era
p (Data era
d, ExUnits
_ex) ->
          -- XXX: Should soon be available through cardano-ledger-api again
          case TxBody era
-> PlutusPurpose AsIx era
-> StrictMaybe (PlutusPurpose AsIxItem era)
forall era.
AlonzoEraTxBody era =>
TxBody era
-> PlutusPurpose AsIx era
-> StrictMaybe (PlutusPurpose AsIxItem era)
redeemerPointerInverse (Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL) PlutusPurpose AsIx era
p of
            SJust (ConwaySpending (AsIxItem Word32
_ TxIn (EraCrypto era)
txIn)) -> TxIn (EraCrypto era)
-> Data era -> Map (TxIn (EraCrypto era)) (Data era)
forall k a. k -> a -> Map k a
Map.singleton TxIn (EraCrypto era)
txIn Data era
d
            StrictMaybe (PlutusPurpose AsIxItem era)
_ -> Map (TxIn (EraCrypto era)) (Data era)
forall a. Monoid a => a
mempty
      )
      (Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers (Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Redeemers era
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era
-> Getting (Redeemers era) (Tx era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx era -> Const (Redeemers era) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx era -> Const (Redeemers era) (Tx era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx era) (Redeemers era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Const (Redeemers era) (Redeemers era))
-> TxWits era -> Const (Redeemers era) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL)

  nonSpendingRedeemers :: Tx era -> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
nonSpendingRedeemers Tx era
tx =
    (PlutusPurpose AsIx era
 -> (Data era, ExUnits)
 -> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))])
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
      ( \PlutusPurpose AsIx era
p (Data era
d, ExUnits
ex) ->
          case TxBody era
-> PlutusPurpose AsIx era
-> StrictMaybe (PlutusPurpose AsIxItem era)
forall era.
AlonzoEraTxBody era =>
TxBody era
-> PlutusPurpose AsIx era
-> StrictMaybe (PlutusPurpose AsIxItem era)
redeemerPointerInverse (Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL) PlutusPurpose AsIx era
p of
            SJust (ConwayMinting (AsIxItem Word32
i PolicyID (EraCrypto era)
_)) -> [(AsIx Word32 (PolicyID (EraCrypto era))
-> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (PolicyID (EraCrypto era)) -> ConwayPlutusPurpose f era
ConwayMinting (Word32 -> AsIx Word32 (PolicyID (EraCrypto era))
forall ix it. ix -> AsIx ix it
AsIx Word32
i), (Data era
d, ExUnits
ex))]
            SJust (ConwayRewarding (AsIxItem Word32
i RewardAccount (EraCrypto era)
_)) -> [(AsIx Word32 (RewardAccount (EraCrypto era))
-> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (RewardAccount (EraCrypto era))
-> ConwayPlutusPurpose f era
ConwayRewarding (Word32 -> AsIx Word32 (RewardAccount (EraCrypto era))
forall ix it. ix -> AsIx ix it
AsIx Word32
i), (Data era
d, ExUnits
ex))]
            SJust (ConwayCertifying (AsIxItem Word32
i TxCert era
_)) -> [(AsIx Word32 (TxCert era) -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> ConwayPlutusPurpose f era
ConwayCertifying (Word32 -> AsIx Word32 (TxCert era)
forall ix it. ix -> AsIx ix it
AsIx Word32
i), (Data era
d, ExUnits
ex))]
            SJust (ConwayProposing (AsIxItem Word32
i ProposalProcedure era
_)) -> [(AsIx Word32 (ProposalProcedure era) -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (ProposalProcedure era) -> ConwayPlutusPurpose f era
ConwayProposing (Word32 -> AsIx Word32 (ProposalProcedure era)
forall ix it. ix -> AsIx ix it
AsIx Word32
i), (Data era
d, ExUnits
ex))]
            SJust (ConwayVoting (AsIxItem Word32
i Voter (EraCrypto era)
_)) -> [(AsIx Word32 (Voter (EraCrypto era)) -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (Voter (EraCrypto era)) -> ConwayPlutusPurpose f era
ConwayVoting (Word32 -> AsIx Word32 (Voter (EraCrypto era))
forall ix it. ix -> AsIx ix it
AsIx Word32
i), (Data era
d, ExUnits
ex))]
            SJust (ConwaySpending (AsIxItem Word32
_ TxIn (EraCrypto era)
_)) -> []
            StrictMaybe (PlutusPurpose AsIxItem era)
SNothing -> []
      )
      (Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers (Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Redeemers era
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era
-> Getting (Redeemers era) (Tx era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx era -> Const (Redeemers era) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx era -> Const (Redeemers era) (Tx era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx era) (Redeemers era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Const (Redeemers era) (Redeemers era))
-> TxWits era -> Const (Redeemers era) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL)
  initialScriptRef :: TxIn
initialScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference ScriptRegistry
scriptRegistry)

  initialRedeemer :: HashableScriptData
initialRedeemer =
    Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData)
-> (InitialRedeemer -> Redeemer)
-> InitialRedeemer
-> HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialRedeemer -> Redeemer
Initial.redeemer (InitialRedeemer -> HashableScriptData)
-> InitialRedeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
      [TxOutRef] -> InitialRedeemer
Initial.ViaCommit (TxIn -> TxOutRef
toPlutusTxOutRef (TxIn -> TxOutRef) -> [TxIn] -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn]
committedTxIns)

  committedTxIns :: [TxIn]
committedTxIns = Tx -> [TxIn]
forall era. Tx era -> [TxIn]
txIns' Tx
blueprintTx

  commitOutput :: TxOut CtxUTxO
commitOutput =
    AddressInEra
-> Value -> TxOutDatum CtxUTxO -> ReferenceScript -> TxOut CtxUTxO
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
commitAddress Value
commitValue TxOutDatum CtxUTxO
commitDatum ReferenceScript
ReferenceScriptNone

  commitAddress :: AddressInEra
commitAddress =
    NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
commitValidatorScript

  utxoToCommit :: UTxO' (TxOut CtxUTxO)
utxoToCommit =
    [(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO)
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO))
-> [(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ (TxIn -> Maybe (TxIn, TxOut CtxUTxO))
-> [TxIn] -> [(TxIn, TxOut CtxUTxO)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\TxIn
txin -> (TxIn
txin,) (TxOut CtxUTxO -> (TxIn, TxOut CtxUTxO))
-> Maybe (TxOut CtxUTxO) -> Maybe (TxIn, TxOut CtxUTxO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxIn -> UTxO' (TxOut CtxUTxO) -> Maybe (TxOut CtxUTxO)
forall out. TxIn -> UTxO' out -> Maybe out
UTxO.resolve TxIn
txin UTxO' (TxOut CtxUTxO)
UTxOType Tx
lookupUTxO) [TxIn]
committedTxIns

  commitValue :: Value
commitValue =
    TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
out Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> (TxOut CtxUTxO -> Value) -> UTxO' (TxOut CtxUTxO) -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue UTxO' (TxOut CtxUTxO)
utxoToCommit

  commitDatum :: TxOutDatum CtxUTxO
commitDatum =
    Datum -> TxOutDatum CtxUTxO
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (Datum -> TxOutDatum CtxUTxO) -> Datum -> TxOutDatum CtxUTxO
forall a b. (a -> b) -> a -> b
$ Party -> UTxO' (TxOut CtxUTxO) -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO' (TxOut CtxUTxO)
utxoToCommit (HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId)

  CommitBlueprintTx{UTxOType Tx
lookupUTxO :: UTxOType Tx
$sel:lookupUTxO:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> UTxOType tx
lookupUTxO, Tx
blueprintTx :: Tx
$sel:blueprintTx:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> tx
blueprintTx} = CommitBlueprintTx Tx
commitBlueprintTx

mkCommitDatum :: Party -> UTxO -> CurrencySymbol -> Plutus.Datum
mkCommitDatum :: Party -> UTxO' (TxOut CtxUTxO) -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO' (TxOut CtxUTxO)
utxo CurrencySymbol
headId =
  DatumType -> Datum
Commit.datum (Party -> Party
partyToChain Party
party, [Commit]
commits, CurrencySymbol
headId)
 where
  commits :: [Commit]
commits =
    ((TxIn, TxOut CtxUTxO) -> Maybe Commit)
-> [(TxIn, TxOut CtxUTxO)] -> [Commit]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxIn, TxOut CtxUTxO) -> Maybe Commit
Commit.serializeCommit ([(TxIn, TxOut CtxUTxO)] -> [Commit])
-> [(TxIn, TxOut CtxUTxO)] -> [Commit]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO)
utxo

-- * Observation

-- | Full observation of a commit transaction.
data CommitObservation = CommitObservation
  { CommitObservation -> (TxIn, TxOut CtxUTxO)
commitOutput :: (TxIn, TxOut CtxUTxO)
  , CommitObservation -> Party
party :: Party
  -- ^ Hydra participant who committed the UTxO.
  , CommitObservation -> UTxO' (TxOut CtxUTxO)
committed :: UTxO
  , CommitObservation -> HeadId
headId :: HeadId
  }
  deriving stock (CommitObservation -> CommitObservation -> Bool
(CommitObservation -> CommitObservation -> Bool)
-> (CommitObservation -> CommitObservation -> Bool)
-> Eq CommitObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommitObservation -> CommitObservation -> Bool
== :: CommitObservation -> CommitObservation -> Bool
$c/= :: CommitObservation -> CommitObservation -> Bool
/= :: CommitObservation -> CommitObservation -> Bool
Eq, Int -> CommitObservation -> ShowS
[CommitObservation] -> ShowS
CommitObservation -> String
(Int -> CommitObservation -> ShowS)
-> (CommitObservation -> String)
-> ([CommitObservation] -> ShowS)
-> Show CommitObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommitObservation -> ShowS
showsPrec :: Int -> CommitObservation -> ShowS
$cshow :: CommitObservation -> String
show :: CommitObservation -> String
$cshowList :: [CommitObservation] -> ShowS
showList :: [CommitObservation] -> ShowS
Show, (forall x. CommitObservation -> Rep CommitObservation x)
-> (forall x. Rep CommitObservation x -> CommitObservation)
-> Generic CommitObservation
forall x. Rep CommitObservation x -> CommitObservation
forall x. CommitObservation -> Rep CommitObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommitObservation -> Rep CommitObservation x
from :: forall x. CommitObservation -> Rep CommitObservation x
$cto :: forall x. Rep CommitObservation x -> CommitObservation
to :: forall x. Rep CommitObservation x -> CommitObservation
Generic)

-- | Identify a commit tx by:
--
-- - Check that its spending from the init validator,
-- - Find the outputs which pays to the commit validator,
-- - Using the datum of that output, deserialize the committed output,
-- - Reconstruct the committed UTxO from both values (tx input and output).
observeCommitTx ::
  NetworkId ->
  -- | A UTxO set to lookup tx inputs. Should at least contain the input
  -- spending from νInitial.
  UTxO ->
  Tx ->
  Maybe CommitObservation
observeCommitTx :: NetworkId -> UTxO' (TxOut CtxUTxO) -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
  -- NOTE: Instead checking to spend from initial we could be looking at the
  -- seed:
  --
  --  - We must check that participation token in output satisfies
  --      policyId = hash(mu_head(seed))
  --
  --  - This allows us to assume (by induction) the output datum at the commit
  --    script is legit
  --
  --  - Further, we need to assert / assume that only one script is spent = onle
  --    one redeemer matches the InitialRedeemer, as we do not have information
  --    which of the inputs is spending from the initial script otherwise.
  --
  --  Right now we only have the headId in the datum, so we use that in place of
  --  the seed -> THIS CAN NOT BE TRUSTED.
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isSpendingFromInitial

  (TxIn
commitIn, TxOut CtxTx Era
commitOut) <- AddressInEra -> Tx -> Maybe (TxIn, TxOut CtxTx Era)
forall era.
AddressInEra era -> Tx era -> Maybe (TxIn, TxOut CtxTx era)
findTxOutByAddress AddressInEra
commitAddress Tx
tx
  HashableScriptData
dat <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData TxOut CtxTx Era
commitOut
  (Party
onChainParty, [Commit]
onChainCommits, CurrencySymbol
headId) :: Commit.DatumType <- HashableScriptData -> Maybe DatumType
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
dat
  Party
party <- Party -> Maybe Party
forall (m :: * -> *). MonadFail m => Party -> m Party
partyFromChain Party
onChainParty

  -- NOTE: If we have the resolved inputs (utxo) then we could avoid putting
  -- the commit into the datum (+ changing the hashing strategy of
  -- collect/fanout)
  UTxO' (TxOut CtxUTxO)
committed <- do
    [(TxIn, TxOut CtxUTxO)]
committedUTxO <- (Commit -> Maybe (TxIn, TxOut CtxUTxO))
-> [Commit] -> Maybe [(TxIn, TxOut CtxUTxO)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO)
Commit.deserializeCommit (NetworkId -> Network
networkIdToNetwork NetworkId
networkId)) [Commit]
onChainCommits
    UTxO' (TxOut CtxUTxO) -> Maybe (UTxO' (TxOut CtxUTxO))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO) -> Maybe (UTxO' (TxOut CtxUTxO)))
-> ([(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO))
-> [(TxIn, TxOut CtxUTxO)]
-> Maybe (UTxO' (TxOut CtxUTxO))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO)
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO)] -> Maybe (UTxO' (TxOut CtxUTxO)))
-> [(TxIn, TxOut CtxUTxO)] -> Maybe (UTxO' (TxOut CtxUTxO))
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO)]
committedUTxO

  PolicyId
policyId <- CurrencySymbol -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m PolicyId
fromPlutusCurrencySymbol CurrencySymbol
headId
  CommitObservation -> Maybe CommitObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    CommitObservation
      { $sel:commitOutput:CommitObservation :: (TxIn, TxOut CtxUTxO)
commitOutput = (TxIn
commitIn, TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx Era
commitOut)
      , Party
$sel:party:CommitObservation :: Party
party :: Party
party
      , UTxO' (TxOut CtxUTxO)
$sel:committed:CommitObservation :: UTxO' (TxOut CtxUTxO)
committed :: UTxO' (TxOut CtxUTxO)
committed
      , $sel:headId:CommitObservation :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
policyId
      }
 where
  isSpendingFromInitial :: Bool
  isSpendingFromInitial :: Bool
isSpendingFromInitial =
    (TxOut CtxUTxO -> Bool) -> UTxO' (TxOut CtxUTxO) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TxOut CtxUTxO
o -> TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO
o AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
initialAddress) (UTxO' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx)

  initialAddress :: AddressInEra
initialAddress = NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
initialValidatorScript

  commitAddress :: AddressInEra
commitAddress = NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
commitValidatorScript