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)
import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..))
import Hydra.Tx.HeadId (HeadId, headIdToCurrencySymbol)
import Hydra.Tx.Party (Party, partyToChain)
import Hydra.Tx.ScriptRegistry (ScriptRegistry, initialReference)
import Hydra.Tx.Utils (addMetadata, mkHydraHeadV1TxName)
import PlutusLedgerApi.V3 (CurrencySymbol)
import PlutusLedgerApi.V3 qualified as Plutus

mkCommitDatum :: Party -> UTxO -> CurrencySymbol -> Plutus.Datum
mkCommitDatum :: Party -> UTxO -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO
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 -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO
utxo

-- | 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

  commitScript :: PlutusScript PlutusScriptV3
commitScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
commitValidatorScript

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

  utxoToCommit :: UTxO
utxoToCommit =
    [(TxIn, TxOut CtxUTxO)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO)] -> UTxO
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 -> Maybe (TxOut CtxUTxO)
forall out. TxIn -> UTxO' out -> Maybe out
UTxO.resolve TxIn
txin UTxO
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 -> 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
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 -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO
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