module Hydra.Tx.Fanout where

import Hydra.Cardano.Api
import Hydra.Prelude

import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.MintAction (MintAction (..))
import Hydra.Ledger.Cardano.Builder (
  addInputs,
  addOutputs,
  addReferenceInputs,
  burnTokens,
  emptyTxBody,
  setValidityLowerBound,
  unsafeBuildTransaction,
 )
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..))
import Hydra.Tx.Utils (headTokensFromValue, mkHydraHeadV1TxName)

-- | Create the fanout transaction, which distributes the closed state
-- accordingly. The head validator allows fanout only > deadline, so we need
-- to set the lower bound to be deadline + 1 slot.
fanoutTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Snapshotted UTxO to fanout on layer 1
  UTxO ->
  -- | Snapshotted decommit UTxO to fanout on layer 1
  Maybe UTxO ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  -- | Minting Policy script, made from initial seed
  PlutusScript ->
  Tx
fanoutTx :: ScriptRegistry
-> UTxO
-> Maybe UTxO
-> (TxIn, TxOut CtxUTxO)
-> SlotNo
-> PlutusScript
-> Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO
utxo Maybe UTxO
utxoToDecommit (TxIn
headInput, TxOut CtxUTxO
headOutput) SlotNo
deadlineSlotNo PlutusScript
headTokenScript =
  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)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [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]
orderedTxOutsToFanout [TxOut CtxTx] -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx]
orderedTxOutsToDecommit)
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& PlutusScript
-> MintAction
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
burnTokens PlutusScript
headTokenScript MintAction
Burn [(AssetName, Quantity)]
headTokens
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityLowerBound (SlotNo
deadlineSlotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
      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
"FanoutTx")
 where
  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
-> 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
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headScript :: PlutusScript
headScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
  headRedeemer :: ScriptRedeemer
headRedeemer =
    Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Input -> ScriptRedeemer) -> Input -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$
      Head.Fanout
        { $sel:numberOfFanoutOutputs:CollectCom :: Integer
numberOfFanoutOutputs = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ UTxO -> Int
forall a. UTxO' a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length UTxO
utxo
        , $sel:numberOfDecommitOutputs:CollectCom :: Integer
numberOfDecommitOutputs = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> (UTxO -> Int) -> Maybe UTxO -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 UTxO -> Int
forall a. UTxO' a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Maybe UTxO
utxoToDecommit
        }

  headTokens :: [(AssetName, Quantity)]
headTokens =
    PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue PlutusScript
headTokenScript (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
headOutput)

  orderedTxOutsToFanout :: [TxOut CtxTx]
orderedTxOutsToFanout =
    TxOut CtxUTxO -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext (TxOut CtxUTxO -> TxOut CtxTx) -> [TxOut CtxUTxO] -> [TxOut CtxTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UTxO
utxo

  orderedTxOutsToDecommit :: [TxOut CtxTx]
orderedTxOutsToDecommit =
    case Maybe UTxO
utxoToDecommit of
      Maybe UTxO
Nothing -> []
      Just UTxO
decommitUTxO -> TxOut CtxUTxO -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext (TxOut CtxUTxO -> TxOut CtxTx) -> [TxOut CtxUTxO] -> [TxOut CtxTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UTxO
decommitUTxO