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.Accumulator (HydraAccumulator)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.HeadId (HeadId)
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..))
import Hydra.Tx.Utils (findStateToken, headTokensFromValue, mkHydraHeadV2TxName)
import PlutusLedgerApi.V3 (toBuiltin)
import PlutusTx.Builtins (bls12_381_G1_uncompress)

-- * 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 ->
  -- | Full snapshot UTxO (utxo <> commit <> decommit) used to rebuild the accumulator
  -- matching the closed datum. May differ from the fanned-out outputs when an
  -- incremental action was already applied on-chain before close.
  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 ->
  Either Text Tx
fanoutTx :: ScriptRegistry
-> UTxO
-> Maybe UTxO
-> Maybe UTxO
-> UTxO
-> (TxIn, TxOut CtxUTxO)
-> SlotNo
-> PlutusScript
-> Either Text Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO
utxo Maybe UTxO
utxoToCommit Maybe UTxO
utxoToDecommit UTxO
utxoForProof (TxIn
headInput, TxOut CtxUTxO
headOutput) SlotNo
deadlineSlotNo PlutusScript
headTokenScript = do
  BuiltinBLS12_381_G1_Element
fanoutProof <- Either Text BuiltinBLS12_381_G1_Element
computeFanoutProof
  Tx -> Either Text Tx
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either Text Tx) -> Tx -> Either Text Tx
forall a b. (a -> b) -> a -> b
$
    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, BuiltinBLS12_381_G1_Element
-> BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness BuiltinBLS12_381_G1_Element
fanoutProof)]
        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, TxIn
crsScriptRef] 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
mkHydraHeadV2TxName Text
"FanoutTx")
 where
  headWitness :: BuiltinBLS12_381_G1_Element
-> BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness BuiltinBLS12_381_G1_Element
proof =
    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 (BuiltinBLS12_381_G1_Element -> HashableScriptData
headRedeemer BuiltinBLS12_381_G1_Element
proof)

  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)

  crsScriptRef :: TxIn
crsScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
crsReference ScriptRegistry
scriptRegistry)

  accumulator :: HydraAccumulator
accumulator =
    forall tx. IsTx tx => UTxOType tx -> HydraAccumulator
Accumulator.buildFromUTxO @Tx UTxO
UTxOType Tx
utxoForProof

  headRedeemer :: BuiltinBLS12_381_G1_Element -> HashableScriptData
headRedeemer BuiltinBLS12_381_G1_Element
proof =
    Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
      Head.Fanout
        { $sel:numberOfFanoutOutputs:Increment :: Integer
numberOfFanoutOutputs = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
utxo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (UTxO -> Int) -> Maybe UTxO -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 UTxO -> Int
forall era. UTxO era -> Int
UTxO.size Maybe UTxO
utxoToCommit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (UTxO -> Int) -> Maybe UTxO -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 UTxO -> Int
forall era. UTxO era -> Int
UTxO.size Maybe UTxO
utxoToDecommit)
        , $sel:proof:Increment :: BuiltinBLS12_381_G1_Element
proof = BuiltinBLS12_381_G1_Element
proof
        , $sel:crsRef:Increment :: TxOutRef
crsRef = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
crsScriptRef
        }

  computeFanoutProof :: Either Text BuiltinBLS12_381_G1_Element
computeFanoutProof = do
    let subsetUTxO :: UTxO
subsetUTxO = UTxO
utxo UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Maybe UTxO -> UTxO
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe UTxO
utxoToCommit UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Maybe UTxO -> UTxO
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe UTxO
utxoToDecommit
        crs :: [Point1]
crs = Int -> [Point1]
Accumulator.crsG1Points (Int -> [Point1]) -> Int -> [Point1]
forall a b. (a -> b) -> a -> b
$ HydraAccumulator -> Int
Accumulator.requiredCRSPointCount HydraAccumulator
accumulator
    ByteString
proofBytes <- forall tx.
IsTx tx =>
UTxOType tx
-> HydraAccumulator -> [Point1] -> Either Text ByteString
Accumulator.createMembershipProofFromUTxO @Tx UTxO
UTxOType Tx
subsetUTxO HydraAccumulator
accumulator [Point1]
crs
    BuiltinBLS12_381_G1_Element
-> Either Text BuiltinBLS12_381_G1_Element
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuiltinBLS12_381_G1_Element
 -> Either Text BuiltinBLS12_381_G1_Element)
-> BuiltinBLS12_381_G1_Element
-> Either Text BuiltinBLS12_381_G1_Element
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> BuiltinBLS12_381_G1_Element
bls12_381_G1_uncompress (BuiltinByteString -> BuiltinBLS12_381_G1_Element)
-> BuiltinByteString -> BuiltinBLS12_381_G1_Element
forall a b. (a -> b) -> a -> b
$ ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin ByteString
proofBytes

  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 era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs 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 era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs 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 era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
decommitUTxO

-- | Create a partial fanout transaction that distributes a subset of UTxOs
-- and produces a 'FanoutProgress' head output with an updated accumulator.
-- Handles both Closed → FanoutProgress (first step) and FanoutProgress →
-- FanoutProgress (subsequent steps).
--
-- The continuing head output is the first output, followed by the distributed
-- UTxOs. No tokens are burned (that happens on the final full fanout).
partialFanoutTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Subset of UTxOs to distribute in this partial fanout
  UTxO ->
  -- | Head state-machine output to spend
  (TxIn, TxOut CtxUTxO) ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  -- | FanoutProgressDatum from the current head output (the caller converts ClosedDatum if needed)
  Head.FanoutProgressDatum ->
  -- | Remaining accumulator after removing the distributed subset
  HydraAccumulator ->
  Tx
partialFanoutTx :: ScriptRegistry
-> UTxO
-> (TxIn, TxOut CtxUTxO)
-> SlotNo
-> FanoutProgressDatum
-> HydraAccumulator
-> Tx
partialFanoutTx ScriptRegistry
scriptRegistry UTxO
utxoToDistribute (TxIn
headInput, TxOut CtxUTxO
headOutput) SlotNo
deadlineSlotNo FanoutProgressDatum
progressDatum HydraAccumulator
remainingAccumulator =
  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, TxIn
crsScriptRef] 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
headOutputAfter TxOut CtxTx Era -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. a -> [a] -> [a]
: [TxOut CtxTx Era]
orderedDistributedOutputs)
      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
mkHydraHeadV2TxName Text
"PartialFanoutTx")
 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)

  crsScriptRef :: TxIn
crsScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
crsReference 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.PartialFanout
        { $sel:numberOfPartialOutputs:Increment :: Integer
numberOfPartialOutputs = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
utxoToDistribute)
        , $sel:crsRef:Increment :: TxOutRef
crsRef = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
crsScriptRef
        }

  -- Continuing head output with FanoutProgressDatum and reduced value.
  -- The head output value is reduced by the sum of distributed output values,
  -- satisfying the on-chain mustConserveValue check:
  --   headInValue == headOutValue <> foldMap txOutValue distributedOutputs
  headOutputAfter :: TxOut CtxTx Era
headOutputAfter =
    (TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era)
-> TxOut CtxUTxO -> TxOut CtxTx Era
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx Era
-> TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era
forall a b. a -> b -> a
const TxOutDatum CtxTx Era
headDatumAfter) (TxOut CtxUTxO -> TxOut CtxTx Era)
-> TxOut CtxUTxO -> TxOut CtxTx Era
forall a b. (a -> b) -> a -> b
$
      (Value -> Value) -> TxOut CtxUTxO -> TxOut CtxUTxO
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
distributedValue) TxOut CtxUTxO
headOutput

  distributedValue :: Value
distributedValue = UTxO -> Value
forall era. UTxO era -> Value
UTxO.totalValue UTxO
utxoToDistribute

  Head.FanoutProgressDatum
    { CurrencySymbol
headId :: CurrencySymbol
$sel:headId:FanoutProgressDatum :: FanoutProgressDatum -> CurrencySymbol
Head.headId
    , [Party]
parties :: [Party]
$sel:parties:FanoutProgressDatum :: FanoutProgressDatum -> [Party]
Head.parties
    , POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:FanoutProgressDatum :: FanoutProgressDatum -> POSIXTime
Head.contestationDeadline
    , Integer
headAdaOverhead :: Integer
$sel:headAdaOverhead:FanoutProgressDatum :: FanoutProgressDatum -> Integer
Head.headAdaOverhead
    } = FanoutProgressDatum
progressDatum

  headDatumAfter :: TxOutDatum CtxTx Era
headDatumAfter =
    State -> TxOutDatum CtxTx Era
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx Era) -> State -> TxOutDatum CtxTx Era
forall a b. (a -> b) -> a -> b
$
      FanoutProgressDatum -> State
Head.FanoutProgress
        Head.FanoutProgressDatum
          { CurrencySymbol
headId :: CurrencySymbol
$sel:headId:FanoutProgressDatum :: CurrencySymbol
Head.headId
          , [Party]
parties :: [Party]
$sel:parties:FanoutProgressDatum :: [Party]
Head.parties
          , POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:FanoutProgressDatum :: POSIXTime
Head.contestationDeadline
          , $sel:accumulatorCommitment:FanoutProgressDatum :: BuiltinBLS12_381_G1_Element
Head.accumulatorCommitment = HydraAccumulator -> BuiltinBLS12_381_G1_Element
Accumulator.getAccumulatorCommitment HydraAccumulator
remainingAccumulator
          , Integer
headAdaOverhead :: Integer
$sel:headAdaOverhead:FanoutProgressDatum :: Integer
Head.headAdaOverhead
          }

  orderedDistributedOutputs :: [TxOut CtxTx Era]
orderedDistributedOutputs =
    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 era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
utxoToDistribute

-- | Create the final partial fanout transaction that distributes all remaining
-- UTxOs and burns all head tokens. Transitions FanoutProgress → Final.
finalPartialFanoutTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | All remaining UTxOs to distribute in this final fanout
  UTxO ->
  -- | Pre-settled UTxOs: elements committed to by the accumulator but already
  -- paid out on-chain (e.g. via a DecrementTx before close). They are NOT
  -- distributed here but must be included in the accumulator to satisfy the
  -- on-chain KZG identity: A_current = P_distribute * commitment(presettled).
  UTxO ->
  -- | Head state-machine output to spend
  (TxIn, TxOut CtxUTxO) ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  -- | Minting Policy script, made from initial seed
  PlutusScript ->
  Either Text Tx
finalPartialFanoutTx :: ScriptRegistry
-> UTxO
-> UTxO
-> (TxIn, TxOut CtxUTxO)
-> SlotNo
-> PlutusScript
-> Either Text Tx
finalPartialFanoutTx ScriptRegistry
scriptRegistry UTxO
utxoToDistribute UTxO
presettledUTxO (TxIn
headInput, TxOut CtxUTxO
headOutput) SlotNo
deadlineSlotNo PlutusScript
headTokenScript = do
  BuiltinBLS12_381_G1_Element
fanoutProof <- Either Text BuiltinBLS12_381_G1_Element
computeFanoutProof
  Tx -> Either Text Tx
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either Text Tx) -> Tx -> Either Text Tx
forall a b. (a -> b) -> a -> b
$
    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, BuiltinBLS12_381_G1_Element
-> BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness BuiltinBLS12_381_G1_Element
fanoutProof)]
        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, TxIn
crsScriptRef] 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]
orderedDistributedOutputs
        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
mkHydraHeadV2TxName Text
"FinalPartialFanoutTx")
 where
  headWitness :: BuiltinBLS12_381_G1_Element
-> BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness BuiltinBLS12_381_G1_Element
proof =
    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 (BuiltinBLS12_381_G1_Element -> HashableScriptData
headRedeemer BuiltinBLS12_381_G1_Element
proof)

  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)

  crsScriptRef :: TxIn
crsScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
crsReference ScriptRegistry
scriptRegistry)

  headRedeemer :: BuiltinBLS12_381_G1_Element -> HashableScriptData
headRedeemer BuiltinBLS12_381_G1_Element
proof =
    Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
      Head.FinalPartialFanout
        { $sel:numberOfPartialOutputs:Increment :: Integer
numberOfPartialOutputs = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UTxO -> Int
forall era. UTxO era -> Int
UTxO.size UTxO
utxoToDistribute)
        , $sel:proof:Increment :: BuiltinBLS12_381_G1_Element
proof = BuiltinBLS12_381_G1_Element
proof
        , $sel:crsRef:Increment :: TxOutRef
crsRef = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
crsScriptRef
        }

  -- Accumulator for all elements the current FanoutProgressDatum commits to:
  -- the UTxOs being distributed now PLUS any pre-settled ones already paid out.
  remainingAccumulator :: HydraAccumulator
remainingAccumulator = forall tx. IsTx tx => UTxOType tx -> HydraAccumulator
Accumulator.buildFromUTxO @Tx (UTxO
utxoToDistribute UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
presettledUTxO)

  computeFanoutProof :: Either Text BuiltinBLS12_381_G1_Element
computeFanoutProof = do
    let crs :: [Point1]
crs = Int -> [Point1]
Accumulator.crsG1Points (Int -> [Point1]) -> Int -> [Point1]
forall a b. (a -> b) -> a -> b
$ HydraAccumulator -> Int
Accumulator.requiredCRSPointCount HydraAccumulator
remainingAccumulator
    ByteString
proofBytes <- forall tx.
IsTx tx =>
UTxOType tx
-> HydraAccumulator -> [Point1] -> Either Text ByteString
Accumulator.createMembershipProofFromUTxO @Tx UTxO
UTxOType Tx
utxoToDistribute HydraAccumulator
remainingAccumulator [Point1]
crs
    BuiltinBLS12_381_G1_Element
-> Either Text BuiltinBLS12_381_G1_Element
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuiltinBLS12_381_G1_Element
 -> Either Text BuiltinBLS12_381_G1_Element)
-> BuiltinBLS12_381_G1_Element
-> Either Text BuiltinBLS12_381_G1_Element
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> BuiltinBLS12_381_G1_Element
bls12_381_G1_uncompress (BuiltinByteString -> BuiltinBLS12_381_G1_Element)
-> BuiltinByteString -> BuiltinBLS12_381_G1_Element
forall a b. (a -> b) -> a -> b
$ ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin ByteString
proofBytes

  headTokens :: PolicyAssets
headTokens =
    PlutusScript -> Value -> PolicyAssets
headTokensFromValue PlutusScript
headTokenScript (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
headOutput)

  orderedDistributedOutputs :: [TxOut CtxTx Era]
orderedDistributedOutputs =
    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 era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
utxoToDistribute

-- * 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{} -> do
        let fanoutUTxO :: UTxO
fanoutUTxO = [(TxIn, TxOut CtxUTxO)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
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
<$> 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

data PartialFanoutObservation = PartialFanoutObservation
  { PartialFanoutObservation -> HeadId
headId :: HeadId
  , PartialFanoutObservation -> UTxO
distributedOutputs :: UTxO
  }
  deriving stock (PartialFanoutObservation -> PartialFanoutObservation -> Bool
(PartialFanoutObservation -> PartialFanoutObservation -> Bool)
-> (PartialFanoutObservation -> PartialFanoutObservation -> Bool)
-> Eq PartialFanoutObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PartialFanoutObservation -> PartialFanoutObservation -> Bool
== :: PartialFanoutObservation -> PartialFanoutObservation -> Bool
$c/= :: PartialFanoutObservation -> PartialFanoutObservation -> Bool
/= :: PartialFanoutObservation -> PartialFanoutObservation -> Bool
Eq, Int -> PartialFanoutObservation -> ShowS
[PartialFanoutObservation] -> ShowS
PartialFanoutObservation -> String
(Int -> PartialFanoutObservation -> ShowS)
-> (PartialFanoutObservation -> String)
-> ([PartialFanoutObservation] -> ShowS)
-> Show PartialFanoutObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialFanoutObservation -> ShowS
showsPrec :: Int -> PartialFanoutObservation -> ShowS
$cshow :: PartialFanoutObservation -> String
show :: PartialFanoutObservation -> String
$cshowList :: [PartialFanoutObservation] -> ShowS
showList :: [PartialFanoutObservation] -> ShowS
Show, (forall x.
 PartialFanoutObservation -> Rep PartialFanoutObservation x)
-> (forall x.
    Rep PartialFanoutObservation x -> PartialFanoutObservation)
-> Generic PartialFanoutObservation
forall x.
Rep PartialFanoutObservation x -> PartialFanoutObservation
forall x.
PartialFanoutObservation -> Rep PartialFanoutObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
PartialFanoutObservation -> Rep PartialFanoutObservation x
from :: forall x.
PartialFanoutObservation -> Rep PartialFanoutObservation x
$cto :: forall x.
Rep PartialFanoutObservation x -> PartialFanoutObservation
to :: forall x.
Rep PartialFanoutObservation x -> PartialFanoutObservation
Generic)
  deriving anyclass ([PartialFanoutObservation] -> Value
[PartialFanoutObservation] -> Encoding
PartialFanoutObservation -> Bool
PartialFanoutObservation -> Value
PartialFanoutObservation -> Encoding
(PartialFanoutObservation -> Value)
-> (PartialFanoutObservation -> Encoding)
-> ([PartialFanoutObservation] -> Value)
-> ([PartialFanoutObservation] -> Encoding)
-> (PartialFanoutObservation -> Bool)
-> ToJSON PartialFanoutObservation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: PartialFanoutObservation -> Value
toJSON :: PartialFanoutObservation -> Value
$ctoEncoding :: PartialFanoutObservation -> Encoding
toEncoding :: PartialFanoutObservation -> Encoding
$ctoJSONList :: [PartialFanoutObservation] -> Value
toJSONList :: [PartialFanoutObservation] -> Value
$ctoEncodingList :: [PartialFanoutObservation] -> Encoding
toEncodingList :: [PartialFanoutObservation] -> Encoding
$comitField :: PartialFanoutObservation -> Bool
omitField :: PartialFanoutObservation -> Bool
ToJSON, Maybe PartialFanoutObservation
Value -> Parser [PartialFanoutObservation]
Value -> Parser PartialFanoutObservation
(Value -> Parser PartialFanoutObservation)
-> (Value -> Parser [PartialFanoutObservation])
-> Maybe PartialFanoutObservation
-> FromJSON PartialFanoutObservation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PartialFanoutObservation
parseJSON :: Value -> Parser PartialFanoutObservation
$cparseJSONList :: Value -> Parser [PartialFanoutObservation]
parseJSONList :: Value -> Parser [PartialFanoutObservation]
$comittedField :: Maybe PartialFanoutObservation
omittedField :: Maybe PartialFanoutObservation
FromJSON)

-- | Identify a partial fanout tx by looking up the input spending the Head
-- output and decoding its redeemer as PartialFanout.
observePartialFanoutTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe PartialFanoutObservation
observePartialFanoutTx :: UTxO -> Tx -> Maybe PartialFanoutObservation
observePartialFanoutTx 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 PartialFanoutObservation)
-> Maybe PartialFanoutObservation
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.PartialFanout{Integer
$sel:numberOfPartialOutputs:Increment :: Input -> Integer
numberOfPartialOutputs :: Integer
numberOfPartialOutputs} -> do
        let numDistributed :: Int
numDistributed = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
numberOfPartialOutputs
        let distributedOutputs :: UTxO
distributedOutputs =
              [(TxIn, TxOut CtxUTxO)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
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
1 ..])
                  (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
numDistributed (Int -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Int -> [a] -> [a]
drop Int
1 (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx)))
        PartialFanoutObservation -> Maybe PartialFanoutObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PartialFanoutObservation{HeadId
$sel:headId:PartialFanoutObservation :: HeadId
headId :: HeadId
headId, UTxO
$sel:distributedOutputs:PartialFanoutObservation :: UTxO
distributedOutputs :: UTxO
distributedOutputs}
      Input
_ -> Maybe PartialFanoutObservation
forall a. Maybe a
Nothing

-- | Identify a final partial fanout tx by looking up the input spending the Head
-- output and decoding its redeemer as FinalPartialFanout.
-- Returns a FanoutObservation since this is the finalizing step.
observeFinalPartialFanoutTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe FanoutObservation
observeFinalPartialFanoutTx :: UTxO -> Tx -> Maybe FanoutObservation
observeFinalPartialFanoutTx 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.FinalPartialFanout{Integer
$sel:numberOfPartialOutputs:Increment :: Input -> Integer
numberOfPartialOutputs :: Integer
numberOfPartialOutputs} -> do
        let numDistributed :: Int
numDistributed = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
numberOfPartialOutputs
        let fanoutUTxO :: UTxO
fanoutUTxO = [(TxIn, TxOut CtxUTxO)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
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
numDistributed (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