module Hydra.Tx.Fanout where

import Hydra.Cardano.Api
import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
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]
-> Set HashableScriptData
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall build era.
(Applicative (BuildTxWith build), IsBabbageBasedEra era) =>
[TxIn]
-> Set HashableScriptData
-> TxBodyContent build era
-> TxBodyContent build era
addTxInsReference [TxIn
headScriptRef] Set HashableScriptData
forall a. Monoid a => a
mempty
      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
-> PolicyAssets
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> PolicyAssets
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
burnTokens PlutusScript
headTokenScript MintAction
Burn PolicyAssets
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
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> HashableScriptData
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
headRedeemer
  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headRedeemer :: HashableScriptData
headRedeemer =
    Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
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 :: PolicyAssets
headTokens =
    PlutusScript -> Value -> PolicyAssets
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
fromCtxUTxOTxOut (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
fromCtxUTxOTxOut (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
fromCtxUTxOTxOut (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

data FanoutObservation = FanoutObservation
  { FanoutObservation -> HeadId
headId :: HeadId
  , FanoutObservation -> UTxO
fanoutUTxO :: UTxO
  }
  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)
  deriving anyclass ([FanoutObservation] -> Value
[FanoutObservation] -> Encoding
FanoutObservation -> Bool
FanoutObservation -> Value
FanoutObservation -> Encoding
(FanoutObservation -> Value)
-> (FanoutObservation -> Encoding)
-> ([FanoutObservation] -> Value)
-> ([FanoutObservation] -> Encoding)
-> (FanoutObservation -> Bool)
-> ToJSON FanoutObservation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: FanoutObservation -> Value
toJSON :: FanoutObservation -> Value
$ctoEncoding :: FanoutObservation -> Encoding
toEncoding :: FanoutObservation -> Encoding
$ctoJSONList :: [FanoutObservation] -> Value
toJSONList :: [FanoutObservation] -> Value
$ctoEncodingList :: [FanoutObservation] -> Encoding
toEncodingList :: [FanoutObservation] -> Encoding
$comitField :: FanoutObservation -> Bool
omitField :: FanoutObservation -> Bool
ToJSON, Maybe FanoutObservation
Value -> Parser [FanoutObservation]
Value -> Parser FanoutObservation
(Value -> Parser FanoutObservation)
-> (Value -> Parser [FanoutObservation])
-> Maybe FanoutObservation
-> FromJSON FanoutObservation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser FanoutObservation
parseJSON :: Value -> Parser FanoutObservation
$cparseJSONList :: Value -> Parser [FanoutObservation]
parseJSONList :: Value -> Parser [FanoutObservation]
$comittedField :: Maybe FanoutObservation
omittedField :: Maybe FanoutObservation
FromJSON)

-- | 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{Integer
$sel:numberOfFanoutOutputs:CollectCom :: Input -> Integer
numberOfFanoutOutputs :: Integer
numberOfFanoutOutputs, Integer
$sel:numberOfCommitOutputs:CollectCom :: Input -> Integer
numberOfCommitOutputs :: Integer
numberOfCommitOutputs, Integer
$sel:numberOfDecommitOutputs:CollectCom :: Input -> Integer
numberOfDecommitOutputs :: Integer
numberOfDecommitOutputs} -> do
        let allOutputs :: Int
allOutputs = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
numberOfFanoutOutputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
numberOfCommitOutputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
numberOfDecommitOutputs
        let fanoutUTxO :: UTxO
fanoutUTxO = [(TxIn, TxOut CtxUTxO)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromList ([(TxIn, TxOut CtxUTxO)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO)] -> UTxO
forall a b. (a -> b) -> a -> b
$ [TxIn] -> [TxOut CtxUTxO] -> [(TxIn, TxOut CtxUTxO)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Tx -> Word -> TxIn
forall era. Tx era -> Word -> TxIn
mkTxIn Tx
tx (Word -> TxIn) -> [Word] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word
0 ..]) (TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut (TxOut CtxTx Era -> TxOut CtxUTxO)
-> [TxOut CtxTx Era] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Int -> [a] -> [a]
take Int
allOutputs (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx))
        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, UTxO
$sel:fanoutUTxO:FanoutObservation :: UTxO
fanoutUTxO :: UTxO
fanoutUTxO}
      Input
_ -> Maybe FanoutObservation
forall a. Maybe a
Nothing