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 (
  burnTokens,
  unsafeBuildTransaction,
 )
import Hydra.Tx.HeadId (HeadId)
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..))
import Hydra.Tx.Utils (findStateToken, headTokensFromValue, mkHydraHeadV1TxName)

-- * Creation

-- | 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 commit UTxO to fanout on layer 1
  Maybe 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
-> Maybe UTxO
-> (TxIn, TxOut CtxUTxO)
-> SlotNo
-> PlutusScript
-> Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO
utxo Maybe UTxO
utxoToCommit 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
defaultTxBodyContent
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(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
forall era build.
IsBabbageBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsReference [TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts ([TxOut CtxTx Era]
orderedTxOutsToFanout [TxOut CtxTx Era] -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx Era]
orderedTxOutsToCommit [TxOut CtxTx Era] -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Semigroup a => a -> a -> a
<> [TxOut CtxTx Era]
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
& TxValidityLowerBound Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxValidityLowerBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityLowerBound (SlotNo -> TxValidityLowerBound Era
TxValidityLowerBound (SlotNo -> TxValidityLowerBound Era)
-> SlotNo -> TxValidityLowerBound Era
forall a b. (a -> b) -> a -> b
$ 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
Head.validatorScript 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)
  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
$ [TxOut CtxUTxO] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxOut CtxUTxO] -> Int) -> [TxOut CtxUTxO] -> Int
forall a b. (a -> b) -> a -> b
$ UTxO -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UTxO
utxo
        , $sel:numberOfCommitOutputs:CollectCom :: Integer
numberOfCommitOutputs = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [TxOut CtxTx Era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut CtxTx Era]
orderedTxOutsToCommit
        , $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
$ [TxOut CtxTx Era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut CtxTx Era]
orderedTxOutsToDecommit
        }

  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 Era]
orderedTxOutsToFanout =
    TxOut CtxUTxO -> TxOut CtxTx Era
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 Era)
-> [TxOut CtxUTxO] -> [TxOut CtxTx Era]
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

  orderedTxOutsToCommit :: [TxOut CtxTx Era]
orderedTxOutsToCommit =
    case Maybe UTxO
utxoToCommit of
      Maybe UTxO
Nothing -> []
      Just UTxO
commitUTxO -> TxOut CtxUTxO -> TxOut CtxTx Era
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 Era)
-> [TxOut CtxUTxO] -> [TxOut CtxTx Era]
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
commitUTxO

  orderedTxOutsToDecommit :: [TxOut CtxTx Era]
orderedTxOutsToDecommit =
    case Maybe UTxO
utxoToDecommit of
      Maybe UTxO
Nothing -> []
      Just UTxO
decommitUTxO -> TxOut CtxUTxO -> TxOut CtxTx Era
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 Era)
-> [TxOut CtxUTxO] -> [TxOut CtxTx Era]
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

-- * Observation

newtype FanoutObservation = FanoutObservation {FanoutObservation -> HeadId
headId :: HeadId}
  deriving stock (FanoutObservation -> FanoutObservation -> Bool
(FanoutObservation -> FanoutObservation -> Bool)
-> (FanoutObservation -> FanoutObservation -> Bool)
-> Eq FanoutObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FanoutObservation -> FanoutObservation -> Bool
== :: FanoutObservation -> FanoutObservation -> Bool
$c/= :: FanoutObservation -> FanoutObservation -> Bool
/= :: FanoutObservation -> FanoutObservation -> Bool
Eq, Int -> FanoutObservation -> ShowS
[FanoutObservation] -> ShowS
FanoutObservation -> String
(Int -> FanoutObservation -> ShowS)
-> (FanoutObservation -> String)
-> ([FanoutObservation] -> ShowS)
-> Show FanoutObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FanoutObservation -> ShowS
showsPrec :: Int -> FanoutObservation -> ShowS
$cshow :: FanoutObservation -> String
show :: FanoutObservation -> String
$cshowList :: [FanoutObservation] -> ShowS
showList :: [FanoutObservation] -> ShowS
Show, (forall x. FanoutObservation -> Rep FanoutObservation x)
-> (forall x. Rep FanoutObservation x -> FanoutObservation)
-> Generic FanoutObservation
forall x. Rep FanoutObservation x -> FanoutObservation
forall x. FanoutObservation -> Rep FanoutObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FanoutObservation -> Rep FanoutObservation x
from :: forall x. FanoutObservation -> Rep FanoutObservation x
$cto :: forall x. Rep FanoutObservation x -> FanoutObservation
to :: forall x. Rep FanoutObservation x -> FanoutObservation
Generic)

-- | Identify a fanout tx by lookup up the input spending the Head output and
-- decoding its redeemer.
observeFanoutTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe FanoutObservation
observeFanoutTx :: UTxO -> Tx -> Maybe FanoutObservation
observeFanoutTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- UTxO -> PlutusScript -> Maybe (TxIn, TxOut CtxUTxO)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript UTxO
inputUTxO PlutusScript
Head.validatorScript
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
    Maybe Input
-> (Input -> Maybe FanoutObservation) -> Maybe FanoutObservation
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Head.Fanout{} -> FanoutObservation -> Maybe FanoutObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FanoutObservation{HeadId
$sel:headId:FanoutObservation :: HeadId
headId :: HeadId
headId}
      Input
_ -> Maybe FanoutObservation
forall a. Maybe a
Nothing