{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Contains the a stateful interface to transaction construction and observation.
--
-- It defines the 'ChainStateType tx' to be used in the 'Hydra.Chain.Direct'
-- layer and it's constituents.
module Hydra.Chain.Direct.State where

import Hydra.Prelude hiding (init)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (PParams)
import GHC.IsList qualified as IsList
import Hydra.Cardano.Api (
  AssetId (..),
  ChainPoint (..),
  CtxUTxO,
  Key (SigningKey, VerificationKey),
  LedgerEra,
  NetworkId,
  PaymentKey,
  PolicyId,
  SlotNo (SlotNo),
  Tx,
  TxId,
  TxIn,
  TxIx (..),
  TxOut,
  UTxO,
  chainPointToSlotNo,
  fromCtxUTxOTxOut,
  fromPlutusTxOutRef,
  fromScriptData,
  isScriptTxOut,
  negateValue,
  toShelleyNetwork,
  txOutScriptData,
  txOutValue,
  utxoFromTx,
  pattern TxIn,
 )
import Hydra.Chain.ChainState (ChainSlot (ChainSlot), IsChainState (..))
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Plutus (depositValidatorScript)
import Hydra.Tx (
  ConfirmedSnapshot (..),
  HeadId (..),
  HeadParameters (..),
  HeadSeed,
  Party,
  ScriptRegistry (..),
  Snapshot (..),
  SnapshotVersion (..),
  getSnapshot,
  headIdToPolicyId,
  headSeedToTxIn,
  partyFromChain,
  partyToChain,
  registryUTxO,
  txInToHeadSeed,
 )
import Hydra.Tx.Accumulator (HydraAccumulator)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.Close (OpenThreadOutput (..), PointInTime, closeTx)
import Hydra.Tx.Contest (ClosedThreadOutput (..), contestTx)
import Hydra.Tx.ContestationPeriod (ContestationPeriod)
import Hydra.Tx.ContestationPeriod qualified as ContestationPeriod
import Hydra.Tx.Crypto (HydraKey, aggregate, generateSigningKey, sign)
import Hydra.Tx.Decrement (decrementTx)
import Hydra.Tx.Deposit (DepositObservation (..), observeDepositTx, observeDepositTxOut)
import Hydra.Tx.DepositPeriod (DepositPeriod)
import Hydra.Tx.DepositPeriod qualified as DepositPeriod
import Hydra.Tx.Fanout (fanoutTx, finalPartialFanoutTx, partialFanoutTx)
import Hydra.Tx.Increment (incrementTx)
import Hydra.Tx.Init (initTx)
import Hydra.Tx.OnChainId (OnChainId)
import Hydra.Tx.Recover (recoverTx)
import Hydra.Tx.Secret (Secret)
import Hydra.Tx.Utils (setIncrementalActionMaybe)

-- | A class for accessing the known 'UTxO' set in a type. This is useful to get
-- all the relevant UTxO for resolving transaction inputs.
class HasKnownUTxO a where
  getKnownUTxO :: a -> UTxO

-- * States & transitions

-- | The chain state used by the Hydra.Chain.Direct implementation. It records
-- the actual 'ChainState' paired with a 'ChainSlot' (used to know up to which
-- point to rewind on rollbacks).
-- XXX: could move this into IsChainState and use UTxOType tx instead of ChainStateType tx
data ChainStateAt = ChainStateAt
  { ChainStateAt -> UTxO
spendableUTxO :: UTxO
  , ChainStateAt -> Maybe ChainPoint
recordedAt :: Maybe ChainPoint
  }
  deriving stock (ChainStateAt -> ChainStateAt -> Bool
(ChainStateAt -> ChainStateAt -> Bool)
-> (ChainStateAt -> ChainStateAt -> Bool) -> Eq ChainStateAt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainStateAt -> ChainStateAt -> Bool
== :: ChainStateAt -> ChainStateAt -> Bool
$c/= :: ChainStateAt -> ChainStateAt -> Bool
/= :: ChainStateAt -> ChainStateAt -> Bool
Eq, Int -> ChainStateAt -> ShowS
[ChainStateAt] -> ShowS
ChainStateAt -> String
(Int -> ChainStateAt -> ShowS)
-> (ChainStateAt -> String)
-> ([ChainStateAt] -> ShowS)
-> Show ChainStateAt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainStateAt -> ShowS
showsPrec :: Int -> ChainStateAt -> ShowS
$cshow :: ChainStateAt -> String
show :: ChainStateAt -> String
$cshowList :: [ChainStateAt] -> ShowS
showList :: [ChainStateAt] -> ShowS
Show, (forall x. ChainStateAt -> Rep ChainStateAt x)
-> (forall x. Rep ChainStateAt x -> ChainStateAt)
-> Generic ChainStateAt
forall x. Rep ChainStateAt x -> ChainStateAt
forall x. ChainStateAt -> Rep ChainStateAt x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainStateAt -> Rep ChainStateAt x
from :: forall x. ChainStateAt -> Rep ChainStateAt x
$cto :: forall x. Rep ChainStateAt x -> ChainStateAt
to :: forall x. Rep ChainStateAt x -> ChainStateAt
Generic)
  deriving anyclass ([ChainStateAt] -> Value
[ChainStateAt] -> Encoding
ChainStateAt -> Bool
ChainStateAt -> Value
ChainStateAt -> Encoding
(ChainStateAt -> Value)
-> (ChainStateAt -> Encoding)
-> ([ChainStateAt] -> Value)
-> ([ChainStateAt] -> Encoding)
-> (ChainStateAt -> Bool)
-> ToJSON ChainStateAt
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ChainStateAt -> Value
toJSON :: ChainStateAt -> Value
$ctoEncoding :: ChainStateAt -> Encoding
toEncoding :: ChainStateAt -> Encoding
$ctoJSONList :: [ChainStateAt] -> Value
toJSONList :: [ChainStateAt] -> Value
$ctoEncodingList :: [ChainStateAt] -> Encoding
toEncodingList :: [ChainStateAt] -> Encoding
$comitField :: ChainStateAt -> Bool
omitField :: ChainStateAt -> Bool
ToJSON, Maybe ChainStateAt
Value -> Parser [ChainStateAt]
Value -> Parser ChainStateAt
(Value -> Parser ChainStateAt)
-> (Value -> Parser [ChainStateAt])
-> Maybe ChainStateAt
-> FromJSON ChainStateAt
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ChainStateAt
parseJSON :: Value -> Parser ChainStateAt
$cparseJSONList :: Value -> Parser [ChainStateAt]
parseJSONList :: Value -> Parser [ChainStateAt]
$comittedField :: Maybe ChainStateAt
omittedField :: Maybe ChainStateAt
FromJSON)

instance ToCBOR ChainStateAt where
  toCBOR :: ChainStateAt -> Encoding
toCBOR = ChainStateAt -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance FromCBOR ChainStateAt where
  fromCBOR :: forall s. Decoder s ChainStateAt
fromCBOR = Decoder s ChainStateAt
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

instance IsChainState Tx where
  type ChainPointType Tx = ChainPoint

  type ChainStateType Tx = ChainStateAt

  chainStatePoint :: ChainStateType Tx -> ChainPointType Tx
chainStatePoint ChainStateAt{Maybe ChainPoint
$sel:recordedAt:ChainStateAt :: ChainStateAt -> Maybe ChainPoint
recordedAt :: Maybe ChainPoint
recordedAt} =
    ChainPoint -> Maybe ChainPoint -> ChainPoint
forall a. a -> Maybe a -> a
fromMaybe ChainPoint
ChainPointAtGenesis Maybe ChainPoint
recordedAt

  chainPointSlot :: ChainPointType Tx -> ChainSlot
chainPointSlot = ChainPoint -> ChainSlot
ChainPointType Tx -> ChainSlot
chainSlotFromPoint

-- | Get a generic 'ChainSlot' from a Cardano 'ChainPoint'. Slot 0 is used for
-- the genesis point.
chainSlotFromPoint :: ChainPoint -> ChainSlot
chainSlotFromPoint :: ChainPoint -> ChainSlot
chainSlotFromPoint ChainPoint
p =
  case ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
p of
    Maybe SlotNo
Nothing -> Natural -> ChainSlot
ChainSlot Natural
0
    Just (SlotNo Word64
s) -> Natural -> ChainSlot
ChainSlot (Natural -> ChainSlot) -> Natural -> ChainSlot
forall a b. (a -> b) -> a -> b
$ Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s

-- | An enumeration of all possible on-chain states of a Hydra Head, where each
-- case stores the relevant information to construct & observe transactions to
-- other states.
data ChainState
  = -- | The idle state does not contain any head-specific information and exists to
    -- be used as a starting and terminal state.
    Idle
  | Open OpenState
  | Closed ClosedState
  deriving stock (ChainState -> ChainState -> Bool
(ChainState -> ChainState -> Bool)
-> (ChainState -> ChainState -> Bool) -> Eq ChainState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainState -> ChainState -> Bool
== :: ChainState -> ChainState -> Bool
$c/= :: ChainState -> ChainState -> Bool
/= :: ChainState -> ChainState -> Bool
Eq, Int -> ChainState -> ShowS
[ChainState] -> ShowS
ChainState -> String
(Int -> ChainState -> ShowS)
-> (ChainState -> String)
-> ([ChainState] -> ShowS)
-> Show ChainState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainState -> ShowS
showsPrec :: Int -> ChainState -> ShowS
$cshow :: ChainState -> String
show :: ChainState -> String
$cshowList :: [ChainState] -> ShowS
showList :: [ChainState] -> ShowS
Show, (forall x. ChainState -> Rep ChainState x)
-> (forall x. Rep ChainState x -> ChainState) -> Generic ChainState
forall x. Rep ChainState x -> ChainState
forall x. ChainState -> Rep ChainState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainState -> Rep ChainState x
from :: forall x. ChainState -> Rep ChainState x
$cto :: forall x. Rep ChainState x -> ChainState
to :: forall x. Rep ChainState x -> ChainState
Generic)

instance HasKnownUTxO ChainState where
  getKnownUTxO :: ChainState -> UTxO
  getKnownUTxO :: ChainState -> UTxO
getKnownUTxO = \case
    ChainState
Idle -> UTxO
forall a. Monoid a => a
mempty
    Open OpenState
st -> OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st
    Closed ClosedState
st -> ClosedState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ClosedState
st

-- | Defines the starting state of the direct chain layer.
initialChainState :: ChainStateType Tx
initialChainState :: ChainStateType Tx
initialChainState =
  ChainStateAt
    { $sel:spendableUTxO:ChainStateAt :: UTxO
spendableUTxO = UTxO
forall a. Monoid a => a
mempty
    , $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = Maybe ChainPoint
forall a. Maybe a
Nothing
    }

-- | Read-only chain-specific data. This is different to 'HydraContext' as it
-- only contains data known to single peer.
data ChainContext = ChainContext
  { ChainContext -> NetworkId
networkId :: NetworkId
  , ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
  , ChainContext -> Party
ownParty :: Party
  , ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
  }
  deriving stock (ChainContext -> ChainContext -> Bool
(ChainContext -> ChainContext -> Bool)
-> (ChainContext -> ChainContext -> Bool) -> Eq ChainContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainContext -> ChainContext -> Bool
== :: ChainContext -> ChainContext -> Bool
$c/= :: ChainContext -> ChainContext -> Bool
/= :: ChainContext -> ChainContext -> Bool
Eq, Int -> ChainContext -> ShowS
[ChainContext] -> ShowS
ChainContext -> String
(Int -> ChainContext -> ShowS)
-> (ChainContext -> String)
-> ([ChainContext] -> ShowS)
-> Show ChainContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainContext -> ShowS
showsPrec :: Int -> ChainContext -> ShowS
$cshow :: ChainContext -> String
show :: ChainContext -> String
$cshowList :: [ChainContext] -> ShowS
showList :: [ChainContext] -> ShowS
Show, (forall x. ChainContext -> Rep ChainContext x)
-> (forall x. Rep ChainContext x -> ChainContext)
-> Generic ChainContext
forall x. Rep ChainContext x -> ChainContext
forall x. ChainContext -> Rep ChainContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainContext -> Rep ChainContext x
from :: forall x. ChainContext -> Rep ChainContext x
$cto :: forall x. Rep ChainContext x -> ChainContext
to :: forall x. Rep ChainContext x -> ChainContext
Generic)

instance HasKnownUTxO ChainContext where
  getKnownUTxO :: ChainContext -> UTxO
getKnownUTxO ChainContext{ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry

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

instance HasKnownUTxO OpenState where
  getKnownUTxO :: OpenState -> UTxO
getKnownUTxO OpenState{UTxO
$sel:openUTxO:OpenState :: OpenState -> UTxO
openUTxO :: UTxO
openUTxO} =
    UTxO
openUTxO

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

instance HasKnownUTxO ClosedState where
  getKnownUTxO :: ClosedState -> UTxO
getKnownUTxO ClosedState{UTxO
$sel:closedUTxO:ClosedState :: ClosedState -> UTxO
closedUTxO :: UTxO
closedUTxO} =
    UTxO
closedUTxO

-- * Constructing transactions

-- | Construct an init transaction given some general 'ChainContext', the
-- 'HeadParameters' and a seed 'TxIn' which will be spent.
initialize ::
  ChainContext ->
  PParams LedgerEra ->
  -- | Seed input.
  TxIn ->
  -- | Verification key hashes of all participants.
  [OnChainId] ->
  HeadParameters ->
  Tx
initialize :: ChainContext
-> PParams LedgerEra -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
ctx =
  NetworkId
-> PParams LedgerEra -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initTx NetworkId
networkId
 where
  ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId} = ChainContext
ctx

data IncrementTxError
  = InvalidHeadSeedInIncrement {IncrementTxError -> HeadSeed
headSeed :: HeadSeed}
  | InvalidHeadIdInIncrement {IncrementTxError -> HeadId
headId :: HeadId}
  | CannotFindHeadOutputInIncrement
  | CannotFindDepositOutputInIncrement {IncrementTxError -> TxId
depositTxId :: TxId}
  | SnapshotMissingIncrementUTxO
  | SnapshotIncrementUTxOIsNull
  | CannotObserveDraftedDeposit
  | CannotDecodeHeadDatumInIncrement
  deriving stock (Int -> IncrementTxError -> ShowS
[IncrementTxError] -> ShowS
IncrementTxError -> String
(Int -> IncrementTxError -> ShowS)
-> (IncrementTxError -> String)
-> ([IncrementTxError] -> ShowS)
-> Show IncrementTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncrementTxError -> ShowS
showsPrec :: Int -> IncrementTxError -> ShowS
$cshow :: IncrementTxError -> String
show :: IncrementTxError -> String
$cshowList :: [IncrementTxError] -> ShowS
showList :: [IncrementTxError] -> ShowS
Show)

-- | Construct a increment transaction spending the head and deposit outputs in given 'UTxO',
-- and producing single head output for pending 'utxoToCommit' of given 'Snapshot'.
increment ::
  ChainContext ->
  -- | Spendable UTxO containing head and deposit outputs
  UTxO ->
  (HeadSeed, HeadId) ->
  HeadParameters ->
  -- | Snapshot to increment with. Also names the deposit to claim.
  ConfirmedSnapshot Tx ->
  -- | Valid until, must be before deadline.
  SlotNo ->
  Either IncrementTxError Tx
increment :: ChainContext
-> UTxO
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Either IncrementTxError Tx
increment ChainContext
ctx UTxO
spendableUTxO (HeadSeed
headSeed, HeadId
headId) HeadParameters
headParameters ConfirmedSnapshot Tx
incrementingSnapshot SlotNo
upperValiditySlot = do
  TxIn
seedTxIn <- HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed Maybe TxIn -> IncrementTxError -> Either IncrementTxError TxIn
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadSeedInIncrement{HeadSeed
$sel:headSeed:InvalidHeadSeedInIncrement :: HeadSeed
headSeed :: HeadSeed
headSeed}
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId
-> IncrementTxError -> Either IncrementTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInIncrement{HeadId
$sel:headId:InvalidHeadSeedInIncrement :: HeadId
headId :: HeadId
headId}
  let utxoOfThisHead' :: UTxO
utxoOfThisHead' = PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO
  (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO <- (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) UTxO
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> IncrementTxError
CannotFindHeadOutputInIncrement
  -- NOTE: the deposit is taken from the snapshot rather than passed in. The
  -- increment validator recomputes the signed commit hash from the deposit input
  -- this transaction spends, so a transaction spending any deposit other than the
  -- one bound into this snapshot cannot validate. Deriving it here makes the two
  -- impossible to disagree.
  TxId
depositTxId <- Maybe (TxIdType Tx)
Maybe TxId
snapshotDepositTxId Maybe TxId -> IncrementTxError -> Either IncrementTxError TxId
forall a e. Maybe a -> e -> Either e a
?> IncrementTxError
SnapshotMissingIncrementUTxO
  -- NOTE: resolve the exact output, not just the transaction id.
  -- 'Hydra.Contract.Head.checkIncrement' requires the claimed deposit to be its
  -- transaction's first output, so accepting any index here could build a
  -- transaction that cannot validate.
  (TxIn
depositedIn, TxOut CtxUTxO ConwayEra
depositedOut) <-
    (TxIn -> TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxIn -> TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.findWithKey
      ( \TxIn
txin TxOut CtxUTxO ConwayEra
txout ->
          TxIn
txin TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxId -> TxIx -> TxIn
TxIn TxId
depositTxId (Word -> TxIx
TxIx Word
0) Bool -> Bool -> Bool
&& PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
depositValidatorScript TxOut CtxUTxO ConwayEra
txout
      )
      UTxO
spendableUTxO
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> CannotFindDepositOutputInIncrement{TxId
$sel:depositTxId:InvalidHeadSeedInIncrement :: TxId
depositTxId :: TxId
depositTxId}
  case Maybe (UTxOType Tx)
utxoToCommit of
    Maybe (UTxOType Tx)
Nothing ->
      IncrementTxError -> Either IncrementTxError Tx
forall a b. a -> Either a b
Left IncrementTxError
SnapshotMissingIncrementUTxO
    Just UTxOType Tx
deposit
      | UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxOType Tx
UTxO
deposit ->
          IncrementTxError -> Either IncrementTxError Tx
forall a b. a -> Either a b
Left IncrementTxError
SnapshotIncrementUTxOIsNull
      | Bool
otherwise ->
          Tx -> Either IncrementTxError Tx
forall a b. b -> Either a b
Right (Tx -> Either IncrementTxError Tx)
-> Tx -> Either IncrementTxError Tx
forall a b. (a -> b) -> a -> b
$
            ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, HeadId)
-> HeadParameters
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> Snapshot Tx
-> UTxO
-> SlotNo
-> MultiSignature (Snapshot Tx)
-> Tx
incrementTx
              ScriptRegistry
scriptRegistry
              VerificationKey PaymentKey
ownVerificationKey
              (TxIn
seedTxIn, HeadId
headId)
              HeadParameters
headParameters
              (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
              Snapshot Tx
sn
              (TxIn -> TxOut CtxUTxO ConwayEra -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
depositedIn TxOut CtxUTxO ConwayEra
depositedOut)
              SlotNo
upperValiditySlot
              MultiSignature (Snapshot Tx)
sigs
 where
  Snapshot{Maybe (UTxOType Tx)
utxoToCommit :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType Tx)
utxoToCommit, $sel:depositTxId:Snapshot :: forall tx. Snapshot tx -> Maybe (TxIdType tx)
depositTxId = Maybe (TxIdType Tx)
snapshotDepositTxId} = Snapshot Tx
sn

  (Snapshot Tx
sn, MultiSignature (Snapshot Tx)
sigs) =
    case ConfirmedSnapshot Tx
incrementingSnapshot of
      ConfirmedSnapshot{Snapshot Tx
snapshot :: Snapshot Tx
$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot, MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures} -> (Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
signatures)
      ConfirmedSnapshot Tx
_ -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
incrementingSnapshot, MultiSignature (Snapshot Tx)
forall a. Monoid a => a
mempty)

  ChainContext{VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx

-- | Build an increment transaction claiming a drafted (not yet submitted)
-- deposit transaction against the current head output. The incrementing
-- snapshot is based on the given current confirmed snapshot, as the next
-- snapshot which would commit the drafted deposit. The result can never
-- validate on chain (for an 'InitialSnapshot' base the multi-signature is
-- fabricated, otherwise the current snapshot's signatures do not cover the
-- fabricated snapshot), but is byte-accurate in every component that matters
-- for size estimation: script witnesses, datum layout, one 64-byte signature
-- per party in the redeemer, and the merged head output value. The head seed,
-- parties and periods are decoded from the current head output's inline datum.
dryRunIncrementTx ::
  ChainContext ->
  -- | Spendable UTxO containing the current head output.
  UTxO ->
  HeadId ->
  -- | Current confirmed snapshot, basis for the incrementing snapshot.
  ConfirmedSnapshot Tx ->
  -- | Drafted (unbalanced) deposit transaction.
  Tx ->
  -- | Upper validity slot.
  SlotNo ->
  Either IncrementTxError Tx
dryRunIncrementTx :: ChainContext
-> UTxO
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either IncrementTxError Tx
dryRunIncrementTx ChainContext
ctx UTxO
spendableUTxO HeadId
headId ConfirmedSnapshot Tx
currentSnapshot Tx
depositDraftTx SlotNo
upperValiditySlot = do
  DepositObservation{UTxO
deposited :: UTxO
$sel:deposited:DepositObservation :: DepositObservation -> UTxO
deposited, TxId
depositTxId :: TxId
$sel:depositTxId:DepositObservation :: DepositObservation -> TxId
depositTxId} <-
    NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
depositDraftTx Maybe DepositObservation
-> IncrementTxError -> Either IncrementTxError DepositObservation
forall a e. Maybe a -> e -> Either e a
?> IncrementTxError
CannotObserveDraftedDeposit
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId
-> IncrementTxError -> Either IncrementTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInIncrement{HeadId
$sel:headId:InvalidHeadSeedInIncrement :: HeadId
headId :: HeadId
headId}
  (TxIn
_, TxOut CtxUTxO ConwayEra
headOut) <-
    (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> IncrementTxError
CannotFindHeadOutputInIncrement
  (HeadSeed
headSeed, HeadParameters
headParameters) <- TxOut CtxUTxO ConwayEra
-> Either IncrementTxError (HeadSeed, HeadParameters)
decodeOpenDatum TxOut CtxUTxO ConwayEra
headOut
  let HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties} = HeadParameters
headParameters
      Snapshot{SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version, SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo, HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: forall tx. Snapshot tx -> HydraAccumulator
accumulator} = ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
currentSnapshot
      snapshot :: Snapshot Tx
snapshot =
        Snapshot
          { HeadId
headId :: HeadId
$sel:headId:Snapshot :: HeadId
headId
          , SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: SnapshotVersion
version
          , $sel:number:Snapshot :: SnapshotNumber
number = SnapshotNumber
number SnapshotNumber -> SnapshotNumber -> SnapshotNumber
forall a. Num a => a -> a -> a
+ SnapshotNumber
1
          , $sel:confirmed:Snapshot :: [Tx]
confirmed = []
          , UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: UTxOType Tx
utxo
          , utxoToCommit :: Maybe (UTxOType Tx)
utxoToCommit = UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
deposited
          , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType Tx)
utxoToDecommit = Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing
          , $sel:depositTxId:Snapshot :: Maybe (TxIdType Tx)
depositTxId = TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
depositTxId
          , -- Only the constant-size hash of the accumulator ends up in the
            -- transaction.
            HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: HydraAccumulator
accumulator
          }
      signatures :: MultiSignature (Snapshot Tx)
signatures = case ConfirmedSnapshot Tx
currentSnapshot of
        -- Real multi-signature of the right multiplicity; that it does not
        -- cover the fabricated snapshot is irrelevant, the dry-run is never
        -- verified.
        ConfirmedSnapshot{$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures = MultiSignature (Snapshot Tx)
sigs} -> MultiSignature (Snapshot Tx)
sigs
        -- The initial snapshot carries no signatures, so fabricate one
        -- never-verified, but byte-identical, signature per party.
        ConfirmedSnapshot Tx
_ -> [Signature (Snapshot Tx)] -> MultiSignature (Snapshot Tx)
forall a. [Signature a] -> MultiSignature a
aggregate (Secret (SigningKey HydraKey)
-> Snapshot Tx -> Signature (Snapshot Tx)
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
dummySigningKey Snapshot Tx
snapshot Signature (Snapshot Tx) -> [Party] -> [Signature (Snapshot Tx)]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Party]
parties)
  ChainContext
-> UTxO
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Either IncrementTxError Tx
increment
    ChainContext
ctx
    -- Inject the not-yet-submitted deposit output into the spendable set.
    (UTxO
spendableUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> Tx -> UTxO
utxoFromTx Tx
depositDraftTx)
    (HeadSeed
headSeed, HeadId
headId)
    HeadParameters
headParameters
    ConfirmedSnapshot{Snapshot Tx
$sel:snapshot:InitialSnapshot :: Snapshot Tx
snapshot :: Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
signatures}
    SlotNo
upperValiditySlot
 where
  dummySigningKey :: Secret (SigningKey HydraKey)
dummySigningKey = ByteString -> Secret (SigningKey HydraKey)
generateSigningKey ByteString
"hydra-dry-run-increment"

  ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId} = ChainContext
ctx

-- | Decode head seed and parameters from the inline datum of a head output.
decodeOpenDatum :: TxOut CtxUTxO -> Either IncrementTxError (HeadSeed, HeadParameters)
decodeOpenDatum :: TxOut CtxUTxO ConwayEra
-> Either IncrementTxError (HeadSeed, HeadParameters)
decodeOpenDatum TxOut CtxUTxO ConwayEra
headOut =
  case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData (HashableScriptData -> Maybe State)
-> Maybe HashableScriptData -> Maybe State
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxOut CtxTx ConwayEra -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO ConwayEra
headOut) of
    Just (Head.Open Head.OpenDatum{TxOutRef
headSeed :: TxOutRef
$sel:headSeed:OpenDatum :: OpenDatum -> TxOutRef
headSeed, $sel:parties:OpenDatum :: OpenDatum -> [Party]
parties = [Party]
onChainParties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:OpenDatum :: OpenDatum -> ContestationPeriod
contestationPeriod, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:OpenDatum :: OpenDatum -> DepositPeriod
depositPeriod}) -> do
      [Party]
parties <- (Party -> Maybe Party) -> [Party] -> Maybe [Party]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Party -> Maybe Party
forall (m :: * -> *). MonadFail m => Party -> m Party
partyFromChain [Party]
onChainParties Maybe [Party]
-> IncrementTxError -> Either IncrementTxError [Party]
forall a e. Maybe a -> e -> Either e a
?> IncrementTxError
CannotDecodeHeadDatumInIncrement
      (HeadSeed, HeadParameters)
-> Either IncrementTxError (HeadSeed, HeadParameters)
forall a. a -> Either IncrementTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( TxIn -> HeadSeed
txInToHeadSeed (TxOutRef -> TxIn
fromPlutusTxOutRef TxOutRef
headSeed)
        , HeadParameters
            { $sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
ContestationPeriod.fromChain ContestationPeriod
contestationPeriod
            , $sel:depositPeriod:HeadParameters :: DepositPeriod
depositPeriod = DepositPeriod -> DepositPeriod
DepositPeriod.fromChain DepositPeriod
depositPeriod
            , [Party]
$sel:parties:HeadParameters :: [Party]
parties :: [Party]
parties
            }
        )
    Maybe State
_ -> IncrementTxError
-> Either IncrementTxError (HeadSeed, HeadParameters)
forall a b. a -> Either a b
Left IncrementTxError
CannotDecodeHeadDatumInIncrement

-- | Possible errors when trying to construct decrement tx
data DecrementTxError
  = InvalidHeadSeedInDecrement {DecrementTxError -> HeadSeed
headSeed :: HeadSeed}
  | InvalidHeadIdInDecrement {DecrementTxError -> HeadId
headId :: HeadId}
  | CannotFindHeadOutputInDecrement
  | DecrementValueNegative
  | SnapshotDecrementUTxOIsNull
  deriving stock (Int -> DecrementTxError -> ShowS
[DecrementTxError] -> ShowS
DecrementTxError -> String
(Int -> DecrementTxError -> ShowS)
-> (DecrementTxError -> String)
-> ([DecrementTxError] -> ShowS)
-> Show DecrementTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecrementTxError -> ShowS
showsPrec :: Int -> DecrementTxError -> ShowS
$cshow :: DecrementTxError -> String
show :: DecrementTxError -> String
$cshowList :: [DecrementTxError] -> ShowS
showList :: [DecrementTxError] -> ShowS
Show)

-- | Construct a decrement transaction spending the head output in given 'UTxO',
-- and producing outputs for all pending 'utxoToDecommit' of given 'Snapshot'.
decrement ::
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  (HeadSeed, HeadId) ->
  HeadParameters ->
  -- | Snapshot to decrement with.
  ConfirmedSnapshot Tx ->
  Either DecrementTxError Tx
decrement :: ChainContext
-> UTxO
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> Either DecrementTxError Tx
decrement ChainContext
ctx UTxO
spendableUTxO (HeadSeed
headSeed, HeadId
headId) HeadParameters
headParameters ConfirmedSnapshot Tx
decrementingSnapshot = do
  TxIn
seedTxIn <- HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed Maybe TxIn -> DecrementTxError -> Either DecrementTxError TxIn
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadSeedInDecrement{HeadSeed
$sel:headSeed:InvalidHeadSeedInDecrement :: HeadSeed
headSeed :: HeadSeed
headSeed}
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId
-> DecrementTxError -> Either DecrementTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInDecrement{HeadId
$sel:headId:InvalidHeadSeedInDecrement :: HeadId
headId :: HeadId
headId}
  let utxoOfThisHead' :: UTxO
utxoOfThisHead' = PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO
  headUTxO :: (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO@(TxIn
_, TxOut CtxUTxO ConwayEra
headOut) <- (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) UTxO
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> DecrementTxError
-> Either DecrementTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> DecrementTxError
CannotFindHeadOutputInDecrement
  let balance :: Value
balance = TxOut CtxUTxO ConwayEra -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO ConwayEra
headOut Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
decommitValue
  Bool -> Either DecrementTxError () -> Either DecrementTxError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value -> Bool
isNegative Value
balance) (Either DecrementTxError () -> Either DecrementTxError ())
-> Either DecrementTxError () -> Either DecrementTxError ()
forall a b. (a -> b) -> a -> b
$
    DecrementTxError -> Either DecrementTxError ()
forall a b. a -> Either a b
Left DecrementTxError
DecrementValueNegative
  Tx -> Either DecrementTxError Tx
forall a b. b -> Either a b
Right (Tx -> Either DecrementTxError Tx)
-> Tx -> Either DecrementTxError Tx
forall a b. (a -> b) -> a -> b
$
    ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, HeadId)
-> HeadParameters
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> Tx
decrementTx
      ScriptRegistry
scriptRegistry
      VerificationKey PaymentKey
ownVerificationKey
      (TxIn
seedTxIn, HeadId
headId)
      HeadParameters
headParameters
      (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
      Snapshot Tx
sn
      MultiSignature (Snapshot Tx)
sigs
 where
  decommitValue :: Value
decommitValue = UTxO -> Value
forall era. UTxO era -> Value
UTxO.totalValue (UTxO -> Value) -> UTxO -> Value
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO -> UTxO
forall a. a -> Maybe a -> a
fromMaybe UTxO
forall a. Monoid a => a
mempty (Maybe UTxO -> UTxO) -> Maybe UTxO -> UTxO
forall a b. (a -> b) -> a -> b
$ Snapshot Tx -> Maybe (UTxOType Tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit Snapshot Tx
sn

  isNegative :: Value -> Bool
isNegative = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
0) (Quantity -> Bool)
-> ((AssetId, Quantity) -> Quantity) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Quantity
forall a b. (a, b) -> b
snd) ([(AssetId, Quantity)] -> Bool)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Value -> [Item Value]
forall l. IsList l => l -> [Item l]
IsList.toList

  (Snapshot Tx
sn, MultiSignature (Snapshot Tx)
sigs) =
    case ConfirmedSnapshot Tx
decrementingSnapshot of
      ConfirmedSnapshot{Snapshot Tx
$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot :: Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot Tx)
signatures} -> (Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
signatures)
      -- XXX: This way of retrofitting an 'InitialSnapshot' into a Snapshot +
      -- Signatures indicates we might want to simplify 'ConfirmedSnapshot' into
      -- a product directly.
      ConfirmedSnapshot Tx
_ -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
decrementingSnapshot, MultiSignature (Snapshot Tx)
forall a. Monoid a => a
mempty)

  ChainContext{VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx

data CloseTxError
  = InvalidHeadIdInClose {CloseTxError -> HeadId
headId :: HeadId}
  | CannotFindHeadOutputToClose
  | BothCommitAndDecommitInClose
  deriving stock (Int -> CloseTxError -> ShowS
[CloseTxError] -> ShowS
CloseTxError -> String
(Int -> CloseTxError -> ShowS)
-> (CloseTxError -> String)
-> ([CloseTxError] -> ShowS)
-> Show CloseTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloseTxError -> ShowS
showsPrec :: Int -> CloseTxError -> ShowS
$cshow :: CloseTxError -> String
show :: CloseTxError -> String
$cshowList :: [CloseTxError] -> ShowS
showList :: [CloseTxError] -> ShowS
Show)

data RecoverTxError
  = InvalidHeadIdInRecover {RecoverTxError -> HeadId
headId :: HeadId}
  | CannotFindDepositOutputToRecover {RecoverTxError -> TxId
depositTxId :: TxId}
  | CannotFindDepositedOutputToRecover {RecoverTxError -> TxId
depositedTxId :: TxId}
  deriving stock (Int -> RecoverTxError -> ShowS
[RecoverTxError] -> ShowS
RecoverTxError -> String
(Int -> RecoverTxError -> ShowS)
-> (RecoverTxError -> String)
-> ([RecoverTxError] -> ShowS)
-> Show RecoverTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecoverTxError -> ShowS
showsPrec :: Int -> RecoverTxError -> ShowS
$cshow :: RecoverTxError -> String
show :: RecoverTxError -> String
$cshowList :: [RecoverTxError] -> ShowS
showList :: [RecoverTxError] -> ShowS
Show)

-- | Construct a recover transaction spending the deposit output
-- and producing outputs the user initially deposited.
recover ::
  ChainContext ->
  HeadId ->
  -- | Deposit TxId
  TxId ->
  -- | Spendable UTxO
  UTxO ->
  SlotNo ->
  Either RecoverTxError Tx
recover :: ChainContext
-> HeadId -> TxId -> UTxO -> SlotNo -> Either RecoverTxError Tx
recover ChainContext
ctx HeadId
headId TxId
depositedTxId UTxO
spendableUTxO SlotNo
lowerValiditySlot = do
  -- NOTE: resolve the exact output, not just the transaction id. 'recoverTx'
  -- spends @TxIn depositedTxId (TxIx 0)@, so accepting any index here would
  -- inspect one output and then spend a different one.
  (TxIn
_, TxOut CtxUTxO ConwayEra
depositedOut) <-
    (TxIn -> TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxIn -> TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.findWithKey
      ( \TxIn
txin TxOut CtxUTxO ConwayEra
txout ->
          TxIn
txin TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxId -> TxIx -> TxIn
TxIn TxId
depositedTxId (Word -> TxIx
TxIx Word
0) Bool -> Bool -> Bool
&& PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
depositValidatorScript TxOut CtxUTxO ConwayEra
txout
      )
      UTxO
spendableUTxO
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> RecoverTxError
-> Either RecoverTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> CannotFindDepositOutputToRecover{$sel:depositTxId:InvalidHeadIdInRecover :: TxId
depositTxId = TxId
depositedTxId}
  (HeadId
headId', UTxO
deposited, POSIXTime
_deadline) <-
    Network
-> TxOut CtxUTxO ConwayEra -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut (NetworkId -> Network
toShelleyNetwork NetworkId
networkId) TxOut CtxUTxO ConwayEra
depositedOut
      Maybe (HeadId, UTxO, POSIXTime)
-> RecoverTxError
-> Either RecoverTxError (HeadId, UTxO, POSIXTime)
forall a e. Maybe a -> e -> Either e a
?> CannotFindDepositedOutputToRecover{$sel:depositedTxId:InvalidHeadIdInRecover :: TxId
depositedTxId = TxId
depositedTxId}
  if HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
/= HeadId
headId'
    then RecoverTxError -> Either RecoverTxError Tx
forall a b. a -> Either a b
Left InvalidHeadIdInRecover{HeadId
$sel:headId:InvalidHeadIdInRecover :: HeadId
headId :: HeadId
headId}
    else Tx -> Either RecoverTxError Tx
forall a b. b -> Either a b
Right (Tx -> Either RecoverTxError Tx) -> Tx -> Either RecoverTxError Tx
forall a b. (a -> b) -> a -> b
$ TxId -> UTxO -> SlotNo -> Tx
recoverTx TxId
depositedTxId UTxO
deposited SlotNo
lowerValiditySlot
 where
  ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId} = ChainContext
ctx

-- | Construct a close transaction spending the head output in given 'UTxO',
-- head parameters, and a confirmed snapshot. NOTE: Lower and upper bound slot
-- difference should not exceed contestation period.
close ::
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  -- | Head id to close.
  HeadId ->
  -- | Parameters of the head to close.
  HeadParameters ->
  -- | Last known version of the open head. NOTE: We deliberately require a
  -- 'SnapshotVersion' to be passed in, even though it could be extracted from the
  -- open head output in the spendable UTxO, to stay consistent with the way
  -- parameters are handled.
  SnapshotVersion ->
  -- | Snapshot to close with.
  ConfirmedSnapshot Tx ->
  -- | 'Tx' validity lower bound
  SlotNo ->
  -- | 'Tx' validity upper bound
  PointInTime ->
  Either CloseTxError Tx
close :: ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties, ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:HeadParameters :: HeadParameters -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod} SnapshotVersion
openVersion ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo PointInTime
pointInTime = do
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> CloseTxError -> Either CloseTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInClose{HeadId
$sel:headId:InvalidHeadIdInClose :: HeadId
headId :: HeadId
headId}
  (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO <-
    (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> CloseTxError
-> Either CloseTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> CloseTxError
CannotFindHeadOutputToClose
  let openThreadOutput :: OpenThreadOutput
openThreadOutput =
        OpenThreadOutput
          { $sel:openThreadUTxO:OpenThreadOutput :: (TxIn, TxOut CtxUTxO ConwayEra)
openThreadUTxO = (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
          , $sel:openContestationPeriod:OpenThreadOutput :: ContestationPeriod
openContestationPeriod = ContestationPeriod -> ContestationPeriod
ContestationPeriod.toChain ContestationPeriod
contestationPeriod
          , $sel:openDepositPeriod:OpenThreadOutput :: DepositPeriod
openDepositPeriod = DepositPeriod -> DepositPeriod
DepositPeriod.toChain DepositPeriod
depositPeriod
          , $sel:openParties:OpenThreadOutput :: [Party]
openParties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
          }

  IncrementalAction
incrementalAction <- Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
setIncrementalActionMaybe Maybe (UTxOType Tx)
Maybe UTxO
utxoToCommit Maybe (UTxOType Tx)
Maybe UTxO
utxoToDecommit Maybe IncrementalAction
-> CloseTxError -> Either CloseTxError IncrementalAction
forall a e. Maybe a -> e -> Either e a
?> CloseTxError
BothCommitAndDecommitInClose
  Tx -> Either CloseTxError Tx
forall a. a -> Either CloseTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either CloseTxError Tx) -> Tx -> Either CloseTxError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> OpenThreadOutput
-> IncrementalAction
-> Tx
closeTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey HeadId
headId SnapshotVersion
openVersion ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo PointInTime
pointInTime OpenThreadOutput
openThreadOutput IncrementalAction
incrementalAction
 where
  Snapshot{Maybe (UTxOType Tx)
utxoToCommit :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType Tx)
utxoToCommit, Maybe (UTxOType Tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType Tx)
utxoToDecommit} = ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot

  ChainContext{VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx

data ContestTxError
  = InvalidHeadIdInContest {ContestTxError -> HeadId
headId :: HeadId}
  | CannotFindHeadOutputToContest
  | MissingHeadDatumInContest
  | MissingHeadRedeemerInContest
  | WrongDatumInContest
  | FailedToConvertFromScriptDataInContest
  deriving stock (Int -> ContestTxError -> ShowS
[ContestTxError] -> ShowS
ContestTxError -> String
(Int -> ContestTxError -> ShowS)
-> (ContestTxError -> String)
-> ([ContestTxError] -> ShowS)
-> Show ContestTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContestTxError -> ShowS
showsPrec :: Int -> ContestTxError -> ShowS
$cshow :: ContestTxError -> String
show :: ContestTxError -> String
$cshowList :: [ContestTxError] -> ShowS
showList :: [ContestTxError] -> ShowS
Show)

-- | Construct a contest transaction based on the 'ClosedState' and a confirmed
-- snapshot. The given 'PointInTime' will be used as an upper validity bound and
-- needs to be before the deadline.
contest ::
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  HeadId ->
  ContestationPeriod ->
  -- | Last known version of the open head. NOTE: We deliberately require a
  -- 'SnapshotVersion' to be passed in, even though it could be extracted from the
  -- open head output in the spendable UTxO, to stay consistent with the way
  -- parameters are handled.
  SnapshotVersion ->
  -- | Snapshot to contest with.
  ConfirmedSnapshot Tx ->
  -- | Current slot and posix time to be used as the contestation time.
  PointInTime ->
  Either ContestTxError Tx
contest :: ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod SnapshotVersion
openVersion ConfirmedSnapshot Tx
contestingSnapshot PointInTime
pointInTime = do
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> ContestTxError -> Either ContestTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInContest{HeadId
$sel:headId:InvalidHeadIdInContest :: HeadId
headId :: HeadId
headId}
  (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO <-
    (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> ContestTxError
-> Either ContestTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> ContestTxError
CannotFindHeadOutputToContest
  ClosedThreadOutput
closedThreadOutput <- (TxIn, TxOut CtxUTxO ConwayEra)
-> Either ContestTxError ClosedThreadOutput
extractProgressDatum (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
  Tx -> Either ContestTxError Tx
forall a. a -> Either ContestTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either ContestTxError Tx) -> Tx -> Either ContestTxError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> PointInTime
-> ClosedThreadOutput
-> Tx
contestTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey HeadId
headId ContestationPeriod
contestationPeriod SnapshotVersion
openVersion Snapshot Tx
sn MultiSignature (Snapshot Tx)
sigs PointInTime
pointInTime ClosedThreadOutput
closedThreadOutput
 where
  extractProgressDatum :: (TxIn, TxOut CtxUTxO ConwayEra)
-> Either ContestTxError ClosedThreadOutput
extractProgressDatum headUTxO :: (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO@(TxIn
_, TxOut CtxUTxO ConwayEra
headOutput) = do
    HashableScriptData
headDatum <- TxOut CtxTx ConwayEra -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO ConwayEra
headOutput) Maybe HashableScriptData
-> ContestTxError -> Either ContestTxError HashableScriptData
forall a e. Maybe a -> e -> Either e a
?> ContestTxError
MissingHeadDatumInContest
    State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
headDatum Maybe State -> ContestTxError -> Either ContestTxError State
forall a e. Maybe a -> e -> Either e a
?> ContestTxError
FailedToConvertFromScriptDataInContest

    case State
datum of
      Head.Closed Head.ClosedDatum{[PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:ClosedDatum :: ClosedDatum -> [PubKeyHash]
contesters, [Party]
parties :: [Party]
$sel:parties:ClosedDatum :: ClosedDatum -> [Party]
parties, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:ClosedDatum :: ClosedDatum -> POSIXTime
contestationDeadline, Integer
headAdaOverhead :: Integer
$sel:headAdaOverhead:ClosedDatum :: ClosedDatum -> Integer
headAdaOverhead, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:ClosedDatum :: ClosedDatum -> DepositPeriod
depositPeriod} -> do
        let closedThreadUTxO :: (TxIn, TxOut CtxUTxO ConwayEra)
closedThreadUTxO = (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
            closedParties :: [Party]
closedParties = [Party]
parties
            closedContestationDeadline :: POSIXTime
closedContestationDeadline = POSIXTime
contestationDeadline
            closedContesters :: [PubKeyHash]
closedContesters = [PubKeyHash]
contesters
        ClosedThreadOutput -> Either ContestTxError ClosedThreadOutput
forall a. a -> Either ContestTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClosedThreadOutput -> Either ContestTxError ClosedThreadOutput)
-> ClosedThreadOutput -> Either ContestTxError ClosedThreadOutput
forall a b. (a -> b) -> a -> b
$
          ClosedThreadOutput
            { (TxIn, TxOut CtxUTxO ConwayEra)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO ConwayEra)
$sel:closedThreadUTxO:ClosedThreadOutput :: (TxIn, TxOut CtxUTxO ConwayEra)
closedThreadUTxO
            , [Party]
closedParties :: [Party]
$sel:closedParties:ClosedThreadOutput :: [Party]
closedParties
            , POSIXTime
closedContestationDeadline :: POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: POSIXTime
closedContestationDeadline
            , [PubKeyHash]
closedContesters :: [PubKeyHash]
$sel:closedContesters:ClosedThreadOutput :: [PubKeyHash]
closedContesters
            , $sel:closedHeadAdaOverhead:ClosedThreadOutput :: Integer
closedHeadAdaOverhead = Integer
headAdaOverhead
            , $sel:closedDepositPeriod:ClosedThreadOutput :: DepositPeriod
closedDepositPeriod = DepositPeriod
depositPeriod
            }
      State
_ -> ContestTxError -> Either ContestTxError ClosedThreadOutput
forall a b. a -> Either a b
Left ContestTxError
WrongDatumInContest

  (Snapshot Tx
sn, MultiSignature (Snapshot Tx)
sigs) =
    case ConfirmedSnapshot Tx
contestingSnapshot of
      ConfirmedSnapshot{Snapshot Tx
$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot :: Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot Tx)
signatures} -> (Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
signatures)
      -- XXX: This way of retrofitting an 'InitialSnapshot' into a Snapshot +
      -- Signatures indicates we might want to simplify 'ConfirmedSnapshot' into
      -- a product directly.
      ConfirmedSnapshot Tx
_ -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
contestingSnapshot, MultiSignature (Snapshot Tx)
forall a. Monoid a => a
mempty)

  ChainContext{VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx

data FanoutTxError
  = CannotFindHeadOutputToFanout
  | MissingHeadDatumInFanout
  | WrongDatumInFanout
  | FailedToConvertFromScriptDataInFanout
  | BothCommitAndDecommitInFanout
  | FailedToCreateFanoutProof Text
  deriving stock (Int -> FanoutTxError -> ShowS
[FanoutTxError] -> ShowS
FanoutTxError -> String
(Int -> FanoutTxError -> ShowS)
-> (FanoutTxError -> String)
-> ([FanoutTxError] -> ShowS)
-> Show FanoutTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FanoutTxError -> ShowS
showsPrec :: Int -> FanoutTxError -> ShowS
$cshow :: FanoutTxError -> String
show :: FanoutTxError -> String
$cshowList :: [FanoutTxError] -> ShowS
showList :: [FanoutTxError] -> ShowS
Show)

-- | Construct a fanout transaction based on the 'ClosedState' and off-chain
-- agreed 'UTxO' set to fan out.
fanout ::
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | Snapshot UTxO to fanout
  UTxO ->
  -- | Snapshot UTxO to commit to fanout
  Maybe UTxO ->
  -- | Snapshot UTxO to decommit to fanout
  Maybe UTxO ->
  -- | Full snapshot UTxO for accumulator (matches closed datum)
  UTxO ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  Either FanoutTxError Tx
fanout :: ChainContext
-> UTxO
-> TxIn
-> UTxO
-> Maybe UTxO
-> Maybe UTxO
-> UTxO
-> SlotNo
-> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo Maybe UTxO
utxoToCommit Maybe UTxO
utxoToDecommit UTxO
utxoForProof SlotNo
deadlineSlotNo = do
  (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO <-
    (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> FanoutTxError
-> Either FanoutTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
CannotFindHeadOutputToFanout
  (TxIn, TxOut CtxUTxO ConwayEra)
closedThreadUTxO <- (TxIn, TxOut CtxUTxO ConwayEra)
-> Either FanoutTxError (TxIn, TxOut CtxUTxO ConwayEra)
extractProgressDatum (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
  IncrementalAction
_ <- Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
setIncrementalActionMaybe Maybe UTxO
utxoToCommit Maybe UTxO
utxoToDecommit Maybe IncrementalAction
-> FanoutTxError -> Either FanoutTxError IncrementalAction
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
BothCommitAndDecommitInFanout
  ScriptRegistry
-> UTxO
-> Maybe UTxO
-> Maybe UTxO
-> UTxO
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> SlotNo
-> PlutusScript PlutusScriptV3
-> Either Text Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO
utxo Maybe UTxO
utxoToCommit Maybe UTxO
utxoToDecommit UTxO
utxoForProof (TxIn, TxOut CtxUTxO ConwayEra)
closedThreadUTxO SlotNo
deadlineSlotNo PlutusScript PlutusScriptV3
headTokenScript
    Either Text Tx
-> (Either Text Tx -> Either FanoutTxError Tx)
-> Either FanoutTxError Tx
forall a b. a -> (a -> b) -> b
& (Text -> FanoutTxError)
-> Either Text Tx -> Either FanoutTxError Tx
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> FanoutTxError
FailedToCreateFanoutProof
 where
  headTokenScript :: PlutusScript PlutusScriptV3
headTokenScript = TxIn -> PlutusScript PlutusScriptV3
mkHeadTokenScript TxIn
seedTxIn

  ChainContext{ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx

  extractProgressDatum :: (TxIn, TxOut CtxUTxO) -> Either FanoutTxError (TxIn, TxOut CtxUTxO)
  extractProgressDatum :: (TxIn, TxOut CtxUTxO ConwayEra)
-> Either FanoutTxError (TxIn, TxOut CtxUTxO ConwayEra)
extractProgressDatum headUTxO :: (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO@(TxIn
_, TxOut CtxUTxO ConwayEra
headOutput) = do
    HashableScriptData
headDatum <-
      TxOut CtxTx ConwayEra -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO ConwayEra
headOutput) Maybe HashableScriptData
-> FanoutTxError -> Either FanoutTxError HashableScriptData
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
MissingHeadDatumInFanout
    State
datum <-
      HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
headDatum Maybe State -> FanoutTxError -> Either FanoutTxError State
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
FailedToConvertFromScriptDataInFanout

    case State
datum of
      Head.Closed{} -> (TxIn, TxOut CtxUTxO ConwayEra)
-> Either FanoutTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a. a -> Either FanoutTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
      State
_ -> FanoutTxError
-> Either FanoutTxError (TxIn, TxOut CtxUTxO ConwayEra)
forall a b. a -> Either a b
Left FanoutTxError
WrongDatumInFanout

-- | Errors that can occur when constructing partial or final-partial fanout transactions.
data PartialFanoutError
  = CannotFindHeadOutput
  | MissingHeadDatum
  | WrongDatum
  | FailedToConvertFromScriptData
  | -- | The on-chain accumulator no longer matches the UTxOs we want to
    -- distribute. This happens when another node already posted a partial
    -- fanout and the chain state moved forward.
    StaleChainState
  | -- | Membership proof generation failed (e.g. subset element not in accumulator
    -- or CRS too short). Indicates a programming error in the caller.
    CannotCreateProof Text
  deriving stock (PartialFanoutError -> PartialFanoutError -> Bool
(PartialFanoutError -> PartialFanoutError -> Bool)
-> (PartialFanoutError -> PartialFanoutError -> Bool)
-> Eq PartialFanoutError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PartialFanoutError -> PartialFanoutError -> Bool
== :: PartialFanoutError -> PartialFanoutError -> Bool
$c/= :: PartialFanoutError -> PartialFanoutError -> Bool
/= :: PartialFanoutError -> PartialFanoutError -> Bool
Eq, Int -> PartialFanoutError -> ShowS
[PartialFanoutError] -> ShowS
PartialFanoutError -> String
(Int -> PartialFanoutError -> ShowS)
-> (PartialFanoutError -> String)
-> ([PartialFanoutError] -> ShowS)
-> Show PartialFanoutError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialFanoutError -> ShowS
showsPrec :: Int -> PartialFanoutError -> ShowS
$cshow :: PartialFanoutError -> String
show :: PartialFanoutError -> String
$cshowList :: [PartialFanoutError] -> ShowS
showList :: [PartialFanoutError] -> ShowS
Show)

-- | Construct a partial fanout transaction that distributes a subset of UTxOs.
-- Handles both first step (Closed → FanoutProgress) and intermediate steps
-- (FanoutProgress → FanoutProgress) by detecting the current on-chain datum type.
-- The first 'chunkSize' UTxOs from 'remainingUTxO' are distributed; the rest become
-- the new remaining set.
partialFanout ::
  ChainContext ->
  -- | Spendable UTxO containing head output
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | Number of UTxOs to distribute in this step
  Int ->
  -- | UTxO used to verify the on-chain accumulator commitment. For the first fanout
  -- step this is utxoForProof (the snapshot's full set, including any decommit UTxOs
  -- that may already have been removed from the head by a DecrementTx). For subsequent
  -- FanoutProgress steps it equals remainingUTxO.
  UTxO ->
  -- | Remaining UTxOs to distribute (will be split into distribute + new remaining)
  UTxO ->
  -- | Contestation deadline as SlotNo
  SlotNo ->
  Either PartialFanoutError Tx
partialFanout :: ChainContext
-> UTxO
-> TxIn
-> Int
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
partialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn Int
chunkSize UTxO
proofUTxO UTxO
remainingUTxO SlotNo
deadlineSlotNo = do
  (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO <-
    (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> PartialFanoutError
-> Either PartialFanoutError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> PartialFanoutError
CannotFindHeadOutput
  State
headState <- (TxIn, TxOut CtxUTxO ConwayEra) -> Either PartialFanoutError State
readHeadState (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
  FanoutProgressDatum
progressDatum <- case State
headState of
    Head.Closed ClosedDatum
closedDatum -> FanoutProgressDatum
-> Either PartialFanoutError FanoutProgressDatum
forall a. a -> Either PartialFanoutError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClosedDatum -> FanoutProgressDatum
Head.progressFromClosed ClosedDatum
closedDatum)
    Head.FanoutProgress FanoutProgressDatum
d -> FanoutProgressDatum
-> Either PartialFanoutError FanoutProgressDatum
forall a. a -> Either PartialFanoutError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FanoutProgressDatum
d
    State
_ -> PartialFanoutError -> Either PartialFanoutError FanoutProgressDatum
forall a b. a -> Either a b
Left PartialFanoutError
WrongDatum
  HydraAccumulator
_fullAccumulator <- FanoutProgressDatum
-> UTxO -> Either PartialFanoutError HydraAccumulator
buildAndVerifyAccumulator FanoutProgressDatum
progressDatum UTxO
proofUTxO
  let allPairs :: [(TxIn, TxOut CtxUTxO ConwayEra)]
allPairs = UTxO -> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
remainingUTxO
      utxoToDistribute :: UTxO
utxoToDistribute = [(TxIn, TxOut CtxUTxO ConwayEra)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall a. Int -> [a] -> [a]
take Int
chunkSize [(TxIn, TxOut CtxUTxO ConwayEra)]
allPairs)
  Bool
-> Either PartialFanoutError () -> Either PartialFanoutError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO
utxoToDistribute) (Either PartialFanoutError () -> Either PartialFanoutError ())
-> Either PartialFanoutError () -> Either PartialFanoutError ()
forall a b. (a -> b) -> a -> b
$ PartialFanoutError -> Either PartialFanoutError ()
forall a b. a -> Either a b
Left (Text -> PartialFanoutError
CannotCreateProof Text
"utxoToDistribute must not be empty")
  let rest :: UTxO
rest = [(TxIn, TxOut CtxUTxO ConwayEra)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall a. Int -> [a] -> [a]
drop Int
chunkSize [(TxIn, TxOut CtxUTxO ConwayEra)]
allPairs)
      -- Pre-settled elements are in proofUTxO (what the accumulator commits to)
      -- but not in remainingUTxO (what we're distributing). They must stay in
      -- the remaining accumulator so the on-chain split identity A = P_K * A'
      -- holds at every step.
      presettled :: UTxO
presettled = UTxO -> UTxO -> UTxO
forall era. UTxO era -> UTxO era -> UTxO era
UTxO.difference UTxO
proofUTxO UTxO
remainingUTxO
  let remainingAccumulator :: HydraAccumulator
remainingAccumulator = forall tx. IsTx tx => UTxOType tx -> HydraAccumulator
Accumulator.buildFromUTxO @Tx (UTxO
rest UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
presettled)
  Tx -> Either PartialFanoutError Tx
forall a. a -> Either PartialFanoutError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either PartialFanoutError Tx)
-> Tx -> Either PartialFanoutError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> UTxO
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> SlotNo
-> FanoutProgressDatum
-> HydraAccumulator
-> Tx
partialFanoutTx ScriptRegistry
scriptRegistry UTxO
utxoToDistribute (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO SlotNo
deadlineSlotNo FanoutProgressDatum
progressDatum HydraAccumulator
remainingAccumulator
 where
  ChainContext{ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx

-- | Construct the final partial fanout transaction that distributes all remaining
-- UTxOs and burns all head tokens. Reads FanoutProgressDatum from the head output.
finalPartialFanout ::
  ChainContext ->
  -- | Spendable UTxO containing head output
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | All remaining UTxOs to distribute
  UTxO ->
  -- | Pre-settled UTxO: elements in the snapshot accumulator that are never
  -- distributed (e.g. a decommit UTxO paid out before close). mempty in normal case.
  UTxO ->
  -- | Contestation deadline as SlotNo
  SlotNo ->
  Either PartialFanoutError Tx
finalPartialFanout :: ChainContext
-> UTxO
-> TxIn
-> UTxO
-> UTxO
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxoToDistribute UTxO
presettledUTxO SlotNo
deadlineSlotNo = do
  (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO <-
    (TxOut CtxUTxO ConwayEra -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO ConwayEra)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO ConwayEra -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO ConwayEra)
-> PartialFanoutError
-> Either PartialFanoutError (TxIn, TxOut CtxUTxO ConwayEra)
forall a e. Maybe a -> e -> Either e a
?> PartialFanoutError
CannotFindHeadOutput
  State
headState <- (TxIn, TxOut CtxUTxO ConwayEra) -> Either PartialFanoutError State
readHeadState (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
  FanoutProgressDatum
progressDatum <- case State
headState of
    Head.FanoutProgress FanoutProgressDatum
d -> FanoutProgressDatum
-> Either PartialFanoutError FanoutProgressDatum
forall a. a -> Either PartialFanoutError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FanoutProgressDatum
d
    State
_ -> PartialFanoutError -> Either PartialFanoutError FanoutProgressDatum
forall a b. a -> Either a b
Left PartialFanoutError
WrongDatum
  HydraAccumulator
_fullAccumulator <- FanoutProgressDatum
-> UTxO -> Either PartialFanoutError HydraAccumulator
buildAndVerifyAccumulator FanoutProgressDatum
progressDatum (UTxO
utxoToDistribute UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
presettledUTxO)
  (Text -> PartialFanoutError)
-> Either Text Tx -> Either PartialFanoutError Tx
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> PartialFanoutError
CannotCreateProof (Either Text Tx -> Either PartialFanoutError Tx)
-> Either Text Tx -> Either PartialFanoutError Tx
forall a b. (a -> b) -> a -> b
$
    ScriptRegistry
-> UTxO
-> UTxO
-> (TxIn, TxOut CtxUTxO ConwayEra)
-> SlotNo
-> PlutusScript PlutusScriptV3
-> Either Text Tx
finalPartialFanoutTx
      ScriptRegistry
scriptRegistry
      UTxO
utxoToDistribute
      UTxO
presettledUTxO
      (TxIn, TxOut CtxUTxO ConwayEra)
headUTxO
      SlotNo
deadlineSlotNo
      PlutusScript PlutusScriptV3
headTokenScript
 where
  headTokenScript :: PlutusScript PlutusScriptV3
headTokenScript = TxIn -> PlutusScript PlutusScriptV3
mkHeadTokenScript TxIn
seedTxIn
  ChainContext{ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx

-- | Read and decode the head state from a head script output.
readHeadState :: (TxIn, TxOut CtxUTxO) -> Either PartialFanoutError Head.State
readHeadState :: (TxIn, TxOut CtxUTxO ConwayEra) -> Either PartialFanoutError State
readHeadState (TxIn
_, TxOut CtxUTxO ConwayEra
headOutput) = do
  HashableScriptData
headDatum <- TxOut CtxTx ConwayEra -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO ConwayEra -> TxOut CtxTx ConwayEra
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO ConwayEra
headOutput) Maybe HashableScriptData
-> PartialFanoutError
-> Either PartialFanoutError HashableScriptData
forall a e. Maybe a -> e -> Either e a
?> PartialFanoutError
MissingHeadDatum
  HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
headDatum Maybe State
-> PartialFanoutError -> Either PartialFanoutError State
forall a e. Maybe a -> e -> Either e a
?> PartialFanoutError
FailedToConvertFromScriptData

-- | Build an accumulator from the given UTxO and verify its commitment matches
-- the one in the on-chain datum. Returns the accumulator for reuse by the caller.
-- Fails with 'StaleChainState' if the commitments differ.
buildAndVerifyAccumulator ::
  Head.FanoutProgressDatum ->
  UTxO ->
  Either PartialFanoutError HydraAccumulator
buildAndVerifyAccumulator :: FanoutProgressDatum
-> UTxO -> Either PartialFanoutError HydraAccumulator
buildAndVerifyAccumulator FanoutProgressDatum
progressDatum UTxO
utxo = do
  let acc :: HydraAccumulator
acc = forall tx. IsTx tx => UTxOType tx -> HydraAccumulator
Accumulator.buildFromUTxO @Tx UTxOType Tx
UTxO
utxo
      Head.FanoutProgressDatum{$sel:accumulatorCommitment:FanoutProgressDatum :: FanoutProgressDatum -> BuiltinBLS12_381_G1_Element
accumulatorCommitment = BuiltinBLS12_381_G1_Element
onChain} = FanoutProgressDatum
progressDatum
  Bool
-> Either PartialFanoutError () -> Either PartialFanoutError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HydraAccumulator -> BuiltinBLS12_381_G1_Element
Accumulator.getAccumulatorCommitment HydraAccumulator
acc BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G1_Element -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinBLS12_381_G1_Element
onChain) (Either PartialFanoutError () -> Either PartialFanoutError ())
-> Either PartialFanoutError () -> Either PartialFanoutError ()
forall a b. (a -> b) -> a -> b
$
    PartialFanoutError -> Either PartialFanoutError ()
forall a b. a -> Either a b
Left PartialFanoutError
StaleChainState
  HydraAccumulator -> Either PartialFanoutError HydraAccumulator
forall a. a -> Either PartialFanoutError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HydraAccumulator
acc

-- * Helpers

utxoOfThisHead :: PolicyId -> UTxO -> UTxO
utxoOfThisHead :: PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
policy = (TxOut CtxUTxO ConwayEra -> Bool) -> UTxO -> UTxO
forall era. (TxOut CtxUTxO era -> Bool) -> UTxO era -> UTxO era
UTxO.filter TxOut CtxUTxO ConwayEra -> Bool
hasHeadToken
 where
  hasHeadToken :: TxOut CtxUTxO ConwayEra -> Bool
hasHeadToken =
    Maybe (AssetId, Quantity) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (AssetId, Quantity) -> Bool)
-> (TxOut CtxUTxO ConwayEra -> Maybe (AssetId, Quantity))
-> TxOut CtxUTxO ConwayEra
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> Bool)
-> [(AssetId, Quantity)] -> Maybe (AssetId, Quantity)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (AssetId, Quantity) -> Bool
isHeadToken ([(AssetId, Quantity)] -> Maybe (AssetId, Quantity))
-> (TxOut CtxUTxO ConwayEra -> [(AssetId, Quantity)])
-> TxOut CtxUTxO ConwayEra
-> Maybe (AssetId, Quantity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Value -> [Item Value]
forall l. IsList l => l -> [Item l]
IsList.toList (Value -> [(AssetId, Quantity)])
-> (TxOut CtxUTxO ConwayEra -> Value)
-> TxOut CtxUTxO ConwayEra
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO ConwayEra -> Value
forall ctx. TxOut ctx -> Value
txOutValue

  isHeadToken :: (AssetId, Quantity) -> Bool
isHeadToken (AssetId
assetId, Quantity
quantity) =
    case AssetId
assetId of
      AssetId
AdaAssetId -> Bool
False
      AssetId PolicyId
pid AssetName
_ -> PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
policy Bool -> Bool -> Bool
&& Quantity
quantity Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1

-- * Generators

-- | Define some 'global' context from which generators can pick
-- values for generation. This allows to write fairly independent generators
-- which however still make sense with one another within the context of a head.
--
-- For example, one can generate a head's _party_ from that global list, whereas
-- other functions may rely on all parties and thus, we need both generation to
-- be coherent.
--
-- Do not use this in production code, but only for generating test data.
data HydraContext = HydraContext
  { HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys :: [VerificationKey PaymentKey]
  , HydraContext -> [Secret (SigningKey HydraKey)]
ctxHydraSigningKeys :: [Secret (SigningKey HydraKey)]
  , HydraContext -> NetworkId
ctxNetworkId :: NetworkId
  , HydraContext -> ContestationPeriod
ctxContestationPeriod :: ContestationPeriod
  , HydraContext -> DepositPeriod
ctxDepositPeriod :: DepositPeriod
  , HydraContext -> ScriptRegistry
ctxScriptRegistry :: ScriptRegistry
  }
  deriving stock (Int -> HydraContext -> ShowS
[HydraContext] -> ShowS
HydraContext -> String
(Int -> HydraContext -> ShowS)
-> (HydraContext -> String)
-> ([HydraContext] -> ShowS)
-> Show HydraContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HydraContext -> ShowS
showsPrec :: Int -> HydraContext -> ShowS
$cshow :: HydraContext -> String
show :: HydraContext -> String
$cshowList :: [HydraContext] -> ShowS
showList :: [HydraContext] -> ShowS
Show)