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 (
  AlonzoTxAuxData (..),
  AsIx (..),
  ConwayPlutusPurpose (..),
  Redeemers (..),
  auxDataHashTxBodyL,
  auxDataTxL,
  bodyTxL,
  hashTxAuxData,
  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.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 (mkHydraHeadV1TxName)
import PlutusLedgerApi.V2 (CurrencySymbol)
import PlutusLedgerApi.V2 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))
-> ((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
& (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 -> AlonzoTx StandardConway -> AlonzoTx StandardConway
addMetadata (Text -> TxMetadata
mkHydraHeadV1TxName Text
"CommitTx")
 where
  addMetadata :: TxMetadata -> AlonzoTx StandardConway -> AlonzoTx StandardConway
addMetadata (TxMetadata Map Word64 TxMetadataValue
newMetadata) AlonzoTx StandardConway
tx =
    let
      newMetadataMap :: Map Word64 Metadatum
newMetadataMap = Map Word64 TxMetadataValue -> Map Word64 Metadatum
toShelleyMetadata Map Word64 TxMetadataValue
newMetadata
      newAuxData :: AlonzoTxAuxData StandardConway
newAuxData =
        case Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx AlonzoTx StandardConway
-> Getting
     (StrictMaybe (AlonzoTxAuxData StandardConway))
     (AlonzoTx StandardConway)
     (StrictMaybe (AlonzoTxAuxData StandardConway))
-> StrictMaybe (AlonzoTxAuxData StandardConway)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (AlonzoTxAuxData StandardConway))
  (AlonzoTx StandardConway)
  (StrictMaybe (AlonzoTxAuxData StandardConway))
(StrictMaybe (AuxiliaryData StandardConway)
 -> Const
      (StrictMaybe (AlonzoTxAuxData StandardConway))
      (StrictMaybe (AuxiliaryData StandardConway)))
-> Tx StandardConway
-> Const
     (StrictMaybe (AlonzoTxAuxData StandardConway)) (Tx StandardConway)
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
Lens'
  (Tx StandardConway) (StrictMaybe (AuxiliaryData StandardConway))
auxDataTxL of
          StrictMaybe (AlonzoTxAuxData StandardConway)
SNothing -> Map Word64 Metadatum
-> StrictSeq (Timelock StandardConway)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData StandardConway
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (Timelock era)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData era
AlonzoTxAuxData Map Word64 Metadatum
newMetadataMap StrictSeq (Timelock StandardConway)
forall a. Monoid a => a
mempty Map Language (NonEmpty PlutusBinary)
forall a. Monoid a => a
mempty
          SJust (AlonzoTxAuxData Map Word64 Metadatum
metadata StrictSeq (Timelock StandardConway)
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap) ->
            Map Word64 Metadatum
-> StrictSeq (Timelock StandardConway)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData StandardConway
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (Timelock era)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData era
AlonzoTxAuxData (Map Word64 Metadatum
-> Map Word64 Metadatum -> Map Word64 Metadatum
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Word64 Metadatum
metadata Map Word64 Metadatum
newMetadataMap) StrictSeq (Timelock StandardConway)
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap
     in
      AlonzoTx StandardConway
tx
        AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (StrictMaybe (AuxiliaryData StandardConway)
 -> Identity (StrictMaybe (AlonzoTxAuxData StandardConway)))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
(StrictMaybe (AuxiliaryData StandardConway)
 -> Identity (StrictMaybe (AuxiliaryData StandardConway)))
-> Tx StandardConway -> Identity (Tx StandardConway)
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
Lens'
  (Tx StandardConway) (StrictMaybe (AuxiliaryData StandardConway))
auxDataTxL ((StrictMaybe (AuxiliaryData StandardConway)
  -> Identity (StrictMaybe (AlonzoTxAuxData StandardConway)))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> StrictMaybe (AlonzoTxAuxData StandardConway)
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData StandardConway
-> StrictMaybe (AlonzoTxAuxData StandardConway)
forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData StandardConway
newAuxData
        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))
-> ((StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))
     -> Identity
          (StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))
    -> Identity
         (StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))
 -> Identity
      (StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
EraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
Lens'
  (TxBody StandardConway)
  (StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway)))
auxDataHashTxBodyL ((StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))
  -> Identity
       (StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AuxiliaryDataHash (EraCrypto StandardConway)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto StandardConway))
forall a. a -> StrictMaybe a
SJust (AuxiliaryData StandardConway
-> AuxiliaryDataHash (EraCrypto StandardConway)
forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData AlonzoTxAuxData StandardConway
AuxiliaryData StandardConway
newAuxData)

  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
& (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 (TxIn StandardCrypto) (Data StandardConway)
-> Set (TxIn StandardCrypto) -> Redeemers StandardConway
forall {era} {era} {k}.
(PlutusPurpose AsIx era ~ ConwayPlutusPurpose AsIx 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 ...),
 AlonzoEraScript era, EraPParams era, Ord k, NFData (TxCert era),
 EncCBOR (TxCert era), DecCBOR (TxCert era)) =>
Map k (Data era) -> Set k -> Redeemers era
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 (Data era) -> Set k -> Redeemers era
mkRedeemers Map k (Data era)
resolved Set k
inputs =
    Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Map (ConwayPlutusPurpose AsIx era) (Data era, ExUnits)
-> Redeemers era
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (Map (ConwayPlutusPurpose AsIx era) (Data era, ExUnits)
 -> Redeemers era)
-> ([(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
    -> Map (ConwayPlutusPurpose AsIx era) (Data era, ExUnits))
-> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
-> Redeemers era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
-> Map (ConwayPlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
 -> Redeemers era)
-> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
-> Redeemers era
forall a b. (a -> b) -> a -> b
$
      ([(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
 -> k -> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))])
-> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
-> Set k
-> [(ConwayPlutusPurpose AsIx era, (Data era, 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, (Data era, 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 (Data era) -> Maybe (Data era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
txin Map k (Data era)
resolved of
                  Maybe (Data era)
Nothing -> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
newRedeemerData
                  Just Data era
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), (Data era
d, Nat -> Nat -> ExUnits
ExUnits Nat
0 Nat
0)) (ConwayPlutusPurpose AsIx era, (Data era, ExUnits))
-> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
-> [(ConwayPlutusPurpose AsIx era, (Data era, ExUnits))]
forall a. a -> [a] -> [a]
: [(ConwayPlutusPurpose AsIx era, (Data era, 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)

  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 lang
commitScript =
    SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Commit.validatorScript

  commitAddress :: AddressInEra
commitAddress =
    forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
networkId PlutusScript PlutusScriptV2
forall {lang}. PlutusScript lang
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