{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}

module Hydra.Tx.CollectCom where

import Data.Map qualified as Map
import Hydra.Cardano.Api
import Hydra.Prelude

import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Ledger.Cardano.Builder (
  addExtraRequiredSigners,
  addInputs,
  addOutputs,
  addReferenceInputs,
  emptyTxBody,
  unsafeBuildTransaction,
 )
import Hydra.Tx.ContestationPeriod (toChain)
import Hydra.Tx.HeadId (HeadId, headIdToCurrencySymbol)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (hashUTxO)
import Hydra.Tx.Party (partyToChain)
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..))
import Hydra.Tx.Utils (mkHydraHeadV1TxName)
import PlutusLedgerApi.V2 (toBuiltin)

-- | Create a transaction collecting all "committed" utxo and opening a Head,
-- i.e. driving the Head script state.
collectComTx ::
  NetworkId ->
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Head identifier
  HeadId ->
  -- | Parameters of the head to collect .
  HeadParameters ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Data needed to spend the commit output produced by each party.
  -- Should contain the PT and is locked by @ν_commit@ script.
  Map TxIn (TxOut CtxUTxO) ->
  -- | UTxO to be used to collect.
  -- Should match whatever is recorded in the commit inputs.
  UTxO ->
  Tx
collectComTx :: NetworkId
-> ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> HeadParameters
-> (TxIn, TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
-> UTxO
-> Tx
collectComTx NetworkId
networkId ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk HeadId
headId HeadParameters
headParameters (TxIn
headInput, TxOut CtxUTxO
initialHeadOutput) Map TxIn (TxOut CtxUTxO)
commits UTxO
utxoToCollect =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs ((TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness) (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
-> TxIns BuildTx -> TxIns BuildTx
forall a. a -> [a] -> [a]
: (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
mkCommit (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)))
-> [TxIn] -> TxIns BuildTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (TxOut CtxUTxO) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (TxOut CtxUTxO)
commits))
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
commitScriptRef, TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx
headOutput]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra Era
TxMetadataInEra (TxMetadata -> TxMetadataInEra Era)
-> TxMetadata -> TxMetadataInEra Era
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"CollectComTx")
 where
  HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod} = HeadParameters
headParameters

  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
    Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript PlutusScriptV2
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript PlutusScriptV2
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
  headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
  headScriptRef :: TxIn
headScriptRef = (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headRedeemer :: ScriptRedeemer
headRedeemer = Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData Input
Head.CollectCom
  headOutput :: TxOut CtxTx
headOutput =
    AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
      (forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
networkId PlutusScript PlutusScriptV2
headScript)
      (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
initialHeadOutput Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
commitValue)
      TxOutDatum CtxTx
headDatumAfter
      ReferenceScript
ReferenceScriptNone
  headDatumAfter :: TxOutDatum CtxTx
headDatumAfter =
    State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx) -> State -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$
      OpenDatum -> State
Head.Open
        Head.OpenDatum
          { $sel:parties:OpenDatum :: [Party]
Head.parties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
          , Hash
ToBuiltin ByteString
utxoHash :: ToBuiltin ByteString
$sel:utxoHash:OpenDatum :: Hash
utxoHash
          , $sel:contestationPeriod:OpenDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod
          , $sel:headId:OpenDatum :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
          , $sel:version:OpenDatum :: SnapshotVersion
version = SnapshotVersion
0
          }

  utxoHash :: ToBuiltin ByteString
utxoHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO
UTxOType Tx
utxoToCollect

  mkCommit :: TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
mkCommit TxIn
commitTxIn = (TxIn
commitTxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
commitWitness)
  commitWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
commitWitness =
    Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript PlutusScriptV2
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
commitScriptRef PlutusScript PlutusScriptV2
commitScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
commitRedeemer
  commitScriptRef :: TxIn
commitScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference ScriptRegistry
scriptRegistry)
  commitValue :: Value
commitValue =
    [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue (TxOut CtxUTxO -> Value) -> [TxOut CtxUTxO] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (TxOut CtxUTxO) -> [TxOut CtxUTxO]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut CtxUTxO)
commits
  commitScript :: PlutusScript PlutusScriptV2
commitScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Commit.validatorScript
  commitRedeemer :: ScriptRedeemer
commitRedeemer =
    Redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Redeemer -> ScriptRedeemer) -> Redeemer -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ RedeemerType -> Redeemer
Commit.redeemer RedeemerType
Commit.ViaCollectCom