{-# 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 Data.Secret (Secret)
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.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 Era
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 Era
getKnownUTxO = \case
    ChainState
Idle -> UTxO Era
forall a. Monoid a => a
mempty
    Open OpenState
st -> OpenState -> UTxO Era
forall a. HasKnownUTxO a => a -> UTxO Era
getKnownUTxO OpenState
st
    Closed ClosedState
st -> ClosedState -> UTxO Era
forall a. HasKnownUTxO a => a -> UTxO Era
getKnownUTxO ClosedState
st

-- | Defines the starting state of the direct chain layer.
initialChainState :: ChainStateType Tx
initialChainState :: ChainStateType Tx
initialChainState =
  ChainStateAt
    { $sel:spendableUTxO:ChainStateAt :: UTxO Era
spendableUTxO = UTxO Era
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 Era
getKnownUTxO ChainContext{ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ScriptRegistry -> UTxO Era
registryUTxO ScriptRegistry
scriptRegistry

data OpenState = OpenState
  { OpenState -> UTxO Era
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 Era
getKnownUTxO OpenState{UTxO Era
$sel:openUTxO:OpenState :: OpenState -> UTxO Era
openUTxO :: UTxO Era
openUTxO} =
    UTxO Era
openUTxO

data ClosedState = ClosedState
  { ClosedState -> UTxO Era
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 Era
getKnownUTxO ClosedState{UTxO Era
$sel:closedUTxO:ClosedState :: ClosedState -> UTxO Era
closedUTxO :: UTxO Era
closedUTxO} =
    UTxO Era
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 Era
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Either IncrementTxError Tx
increment ChainContext
ctx UTxO Era
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 Era
utxoOfThisHead' = PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead PolicyId
pid UTxO Era
spendableUTxO
  (TxIn, TxOut CtxUTxO Era)
headUTxO <- (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) UTxO Era
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO Era)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO Era)
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 Era
depositedOut) <-
    (TxIn -> TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxIn -> TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.findWithKey
      ( \TxIn
txin TxOut CtxUTxO Era
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 Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
depositValidatorScript TxOut CtxUTxO Era
txout
      )
      UTxO Era
spendableUTxO
      Maybe (TxIn, TxOut CtxUTxO Era)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO Era)
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 Era -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxOType Tx
UTxO Era
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 Era)
-> Snapshot Tx
-> UTxO Era
-> SlotNo
-> MultiSignature (Snapshot Tx)
-> Tx
incrementTx
              ScriptRegistry
scriptRegistry
              VerificationKey PaymentKey
ownVerificationKey
              (TxIn
seedTxIn, HeadId
headId)
              HeadParameters
headParameters
              (TxIn, TxOut CtxUTxO Era)
headUTxO
              Snapshot Tx
sn
              (TxIn -> TxOut CtxUTxO Era -> UTxO Era
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
depositedIn TxOut CtxUTxO Era
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 Era
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either IncrementTxError Tx
dryRunIncrementTx ChainContext
ctx UTxO Era
spendableUTxO HeadId
headId ConfirmedSnapshot Tx
currentSnapshot Tx
depositDraftTx SlotNo
upperValiditySlot = do
  DepositObservation{UTxO Era
deposited :: UTxO Era
$sel:deposited:DepositObservation :: DepositObservation -> UTxO Era
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 Era
headOut) <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead PolicyId
pid UTxO Era
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO Era)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> IncrementTxError
CannotFindHeadOutputInIncrement
  (HeadSeed
headSeed, HeadParameters
headParameters) <- TxOut CtxUTxO Era
-> Either IncrementTxError (HeadSeed, HeadParameters)
decodeOpenDatum TxOut CtxUTxO Era
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 Era -> Maybe (UTxO Era)
forall a. a -> Maybe a
Just UTxO Era
deposited
          , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType Tx)
utxoToDecommit = Maybe (UTxOType Tx)
Maybe (UTxO Era)
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 hashes of the accumulators end up in the
            -- transaction, so the fabricated snapshot reuses the current one for
            -- both rather than committing to the deposit for a dry run.
            HydraAccumulator
accumulator :: HydraAccumulator
$sel:accumulator:Snapshot :: HydraAccumulator
accumulator
          , $sel:appliedAccumulator:Snapshot :: HydraAccumulator
appliedAccumulator = 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 Era
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Either IncrementTxError Tx
increment
    ChainContext
ctx
    -- Inject the not-yet-submitted deposit output into the spendable set.
    (UTxO Era
spendableUTxO UTxO Era -> UTxO Era -> UTxO Era
forall a. Semigroup a => a -> a -> a
<> Tx -> UTxO Era
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 Era
-> Either IncrementTxError (HeadSeed, HeadParameters)
decodeOpenDatum TxOut CtxUTxO Era
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 Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO Era
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 Era
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> Either DecrementTxError Tx
decrement ChainContext
ctx UTxO Era
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 Era
utxoOfThisHead' = PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead PolicyId
pid UTxO Era
spendableUTxO
  headUTxO :: (TxIn, TxOut CtxUTxO Era)
headUTxO@(TxIn
_, TxOut CtxUTxO Era
headOut) <- (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) UTxO Era
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO Era)
-> DecrementTxError
-> Either DecrementTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> DecrementTxError
CannotFindHeadOutputInDecrement
  let balance :: Value
balance = TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
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 Era)
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> Tx
decrementTx
      ScriptRegistry
scriptRegistry
      VerificationKey PaymentKey
ownVerificationKey
      (TxIn
seedTxIn, HeadId
headId)
      HeadParameters
headParameters
      (TxIn, TxOut CtxUTxO Era)
headUTxO
      Snapshot Tx
sn
      MultiSignature (Snapshot Tx)
sigs
 where
  decommitValue :: Value
decommitValue = UTxO Era -> Value
forall era. UTxO era -> Value
UTxO.totalValue (UTxO Era -> Value) -> UTxO Era -> Value
forall a b. (a -> b) -> a -> b
$ UTxO Era -> Maybe (UTxO Era) -> UTxO Era
forall a. a -> Maybe a -> a
fromMaybe UTxO Era
forall a. Monoid a => a
mempty (Maybe (UTxO Era) -> UTxO Era) -> Maybe (UTxO Era) -> UTxO Era
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 Era -> SlotNo -> Either RecoverTxError Tx
recover ChainContext
ctx HeadId
headId TxId
depositedTxId UTxO Era
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 Era
depositedOut) <-
    (TxIn -> TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxIn -> TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.findWithKey
      ( \TxIn
txin TxOut CtxUTxO Era
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 Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
depositValidatorScript TxOut CtxUTxO Era
txout
      )
      UTxO Era
spendableUTxO
      Maybe (TxIn, TxOut CtxUTxO Era)
-> RecoverTxError
-> Either RecoverTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> CannotFindDepositOutputToRecover{$sel:depositTxId:InvalidHeadIdInRecover :: TxId
depositTxId = TxId
depositedTxId}
  (HeadId
headId', UTxO Era
deposited, POSIXTime
_deadline) <-
    Network -> TxOut CtxUTxO Era -> Maybe (HeadId, UTxO Era, POSIXTime)
observeDepositTxOut (NetworkId -> Network
toShelleyNetwork NetworkId
networkId) TxOut CtxUTxO Era
depositedOut
      Maybe (HeadId, UTxO Era, POSIXTime)
-> RecoverTxError
-> Either RecoverTxError (HeadId, UTxO Era, 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 Era -> SlotNo -> Tx
recoverTx TxId
depositedTxId UTxO Era
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 Era
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxO Era
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 Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead PolicyId
pid UTxO Era
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO Era)
-> CloseTxError -> Either CloseTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> CloseTxError
CannotFindHeadOutputToClose
  let openThreadOutput :: OpenThreadOutput
openThreadOutput =
        OpenThreadOutput
          { $sel:openThreadUTxO:OpenThreadOutput :: (TxIn, TxOut CtxUTxO Era)
openThreadUTxO = (TxIn, TxOut CtxUTxO Era)
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 Era) -> Maybe (UTxO Era) -> Maybe IncrementalAction
setIncrementalActionMaybe Maybe (UTxOType Tx)
Maybe (UTxO Era)
utxoToCommit Maybe (UTxOType Tx)
Maybe (UTxO Era)
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 Era
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO Era
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 Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead PolicyId
pid UTxO Era
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO Era)
-> ContestTxError
-> Either ContestTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> ContestTxError
CannotFindHeadOutputToContest
  ClosedThreadOutput
closedThreadOutput <- (TxIn, TxOut CtxUTxO Era)
-> Either ContestTxError ClosedThreadOutput
extractProgressDatum (TxIn, TxOut CtxUTxO Era)
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 Era)
-> Either ContestTxError ClosedThreadOutput
extractProgressDatum headUTxO :: (TxIn, TxOut CtxUTxO Era)
headUTxO@(TxIn
_, TxOut CtxUTxO Era
headOutput) = do
    HashableScriptData
headDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO Era
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 Era)
closedThreadUTxO = (TxIn, TxOut CtxUTxO Era)
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 Era)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:closedThreadUTxO:ClosedThreadOutput :: (TxIn, TxOut CtxUTxO Era)
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 ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  Either FanoutTxError Tx
fanout :: ChainContext
-> UTxO Era
-> TxIn
-> UTxO Era
-> Maybe (UTxO Era)
-> Maybe (UTxO Era)
-> SlotNo
-> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO Era
spendableUTxO TxIn
seedTxIn UTxO Era
utxo Maybe (UTxO Era)
utxoToCommit Maybe (UTxO Era)
utxoToDecommit SlotNo
deadlineSlotNo = do
  (TxIn, TxOut CtxUTxO Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO Era
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO Era)
-> FanoutTxError -> Either FanoutTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
CannotFindHeadOutputToFanout
  (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO <- (TxIn, TxOut CtxUTxO Era)
-> Either FanoutTxError (TxIn, TxOut CtxUTxO Era)
extractProgressDatum (TxIn, TxOut CtxUTxO Era)
headUTxO
  IncrementalAction
_ <- Maybe (UTxO Era) -> Maybe (UTxO Era) -> Maybe IncrementalAction
setIncrementalActionMaybe Maybe (UTxO Era)
utxoToCommit Maybe (UTxO Era)
utxoToDecommit Maybe IncrementalAction
-> FanoutTxError -> Either FanoutTxError IncrementalAction
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
BothCommitAndDecommitInFanout
  ScriptRegistry
-> UTxO Era
-> Maybe (UTxO Era)
-> Maybe (UTxO Era)
-> (TxIn, TxOut CtxUTxO Era)
-> SlotNo
-> PlutusScript PlutusScriptV3
-> Either Text Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO Era
utxo Maybe (UTxO Era)
utxoToCommit Maybe (UTxO Era)
utxoToDecommit (TxIn, TxOut CtxUTxO Era)
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 Era)
-> Either FanoutTxError (TxIn, TxOut CtxUTxO Era)
extractProgressDatum headUTxO :: (TxIn, TxOut CtxUTxO Era)
headUTxO@(TxIn
_, TxOut CtxUTxO Era
headOutput) = do
    HashableScriptData
headDatum <-
      TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO Era
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 Era)
-> Either FanoutTxError (TxIn, TxOut CtxUTxO Era)
forall a. a -> Either FanoutTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut CtxUTxO Era)
headUTxO
      State
_ -> FanoutTxError -> Either FanoutTxError (TxIn, TxOut CtxUTxO Era)
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)

-- | Everything a partial fanout needs that does not depend on the chunk size.
-- Chunk sizes are searched for by trying candidate transactions, so this is
-- prepared once per step and reused for each candidate.
data PartialFanoutPlan = PartialFanoutPlan
  { PartialFanoutPlan -> (TxIn, TxOut CtxUTxO Era)
headUTxO :: (TxIn, TxOut CtxUTxO)
  , PartialFanoutPlan -> FanoutProgressDatum
progressDatum :: Head.FanoutProgressDatum
  , PartialFanoutPlan -> HydraAccumulator
fullAccumulator :: HydraAccumulator
  -- ^ Accumulator over the proof UTxO, already verified against the on-chain
  -- commitment. Pre-settled elements (committed to by the accumulator but never
  -- distributed, e.g. a decommit paid out before close) are in here and stay in
  -- the remaining accumulator, because a step only removes what it distributes.
  , PartialFanoutPlan -> [(TxIn, TxOut CtxUTxO Era)]
orderedRemaining :: [(TxIn, TxOut CtxUTxO)]
  -- ^ 'remainingUTxO' in the order chunks are taken from.
  }

-- | Read the head output and verify the on-chain accumulator, yielding a plan
-- to build partial fanout transactions from.
--
-- Handles both the first step (Closed → FanoutProgress) and intermediate steps
-- (FanoutProgress → FanoutProgress) by detecting the current datum type.
preparePartialFanout ::
  -- | Spendable UTxO containing head output
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | UTxO used to verify the on-chain accumulator commitment: everything still
  -- in the head. For the first fanout step this is the fan-out-able set the
  -- closed datum commits to; for subsequent FanoutProgress steps it is the
  -- not-yet-distributed set, which the remaining set only equals when the whole
  -- of it is being distributed: a user selection is a sub-multiset of it, matched
  -- by output content rather than by 'TxIn'.
  UTxO ->
  -- | Remaining UTxOs to distribute
  UTxO ->
  Either PartialFanoutError PartialFanoutPlan
preparePartialFanout :: UTxO Era
-> TxIn
-> UTxO Era
-> UTxO Era
-> Either PartialFanoutError PartialFanoutPlan
preparePartialFanout UTxO Era
spendableUTxO TxIn
seedTxIn UTxO Era
proofUTxO UTxO Era
remainingUTxO = do
  (TxIn, TxOut CtxUTxO Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO Era
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO Era)
-> PartialFanoutError
-> Either PartialFanoutError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> PartialFanoutError
CannotFindHeadOutput
  State
headState <- (TxIn, TxOut CtxUTxO Era) -> Either PartialFanoutError State
readHeadState (TxIn, TxOut CtxUTxO Era)
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 Era -> Either PartialFanoutError HydraAccumulator
buildAndVerifyAccumulator FanoutProgressDatum
progressDatum UTxO Era
proofUTxO
  PartialFanoutPlan -> Either PartialFanoutError PartialFanoutPlan
forall a. a -> Either PartialFanoutError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    PartialFanoutPlan
      { (TxIn, TxOut CtxUTxO Era)
$sel:headUTxO:PartialFanoutPlan :: (TxIn, TxOut CtxUTxO Era)
headUTxO :: (TxIn, TxOut CtxUTxO Era)
headUTxO
      , FanoutProgressDatum
$sel:progressDatum:PartialFanoutPlan :: FanoutProgressDatum
progressDatum :: FanoutProgressDatum
progressDatum
      , HydraAccumulator
$sel:fullAccumulator:PartialFanoutPlan :: HydraAccumulator
fullAccumulator :: HydraAccumulator
fullAccumulator
      , $sel:orderedRemaining:PartialFanoutPlan :: [(TxIn, TxOut CtxUTxO Era)]
orderedRemaining = UTxO Era -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
remainingUTxO
      }

-- | Construct a partial fanout transaction distributing the first 'chunkSize'
-- UTxOs of the plan's remaining set; the rest become the new remaining set.
--
-- The remaining accumulator is the plan's verified one minus the outputs this
-- transaction distributes, rather than rebuilt from scratch. Removing exactly
-- the distributed outputs is what the on-chain split identity @A = P_K * A'@
-- checks, so it holds by construction whenever those outputs are in @A@.
partialFanoutFromPlan ::
  ChainContext ->
  PartialFanoutPlan ->
  -- | Number of UTxOs to distribute in this step
  Int ->
  -- | Contestation deadline as SlotNo
  SlotNo ->
  Either PartialFanoutError Tx
partialFanoutFromPlan :: ChainContext
-> PartialFanoutPlan
-> Int
-> SlotNo
-> Either PartialFanoutError Tx
partialFanoutFromPlan ChainContext
ctx PartialFanoutPlan
plan Int
chunkSize SlotNo
deadlineSlotNo = do
  let utxoToDistribute :: UTxO Era
utxoToDistribute = [(TxIn, TxOut CtxUTxO Era)] -> UTxO Era
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList (Int -> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Int -> [a] -> [a]
take Int
chunkSize [(TxIn, TxOut CtxUTxO Era)]
orderedRemaining)
  Bool
-> Either PartialFanoutError () -> Either PartialFanoutError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTxO Era -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO Era
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 remainingAccumulator :: HydraAccumulator
remainingAccumulator = forall tx.
IsTx tx =>
HydraAccumulator -> UTxOType tx -> HydraAccumulator
Accumulator.removeOutputs @Tx HydraAccumulator
fullAccumulator UTxOType Tx
UTxO Era
utxoToDistribute
  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 Era
-> (TxIn, TxOut CtxUTxO Era)
-> SlotNo
-> FanoutProgressDatum
-> HydraAccumulator
-> Tx
partialFanoutTx ScriptRegistry
scriptRegistry UTxO Era
utxoToDistribute (TxIn, TxOut CtxUTxO Era)
headUTxO SlotNo
deadlineSlotNo FanoutProgressDatum
progressDatum HydraAccumulator
remainingAccumulator
 where
  PartialFanoutPlan{(TxIn, TxOut CtxUTxO Era)
$sel:headUTxO:PartialFanoutPlan :: PartialFanoutPlan -> (TxIn, TxOut CtxUTxO Era)
headUTxO :: (TxIn, TxOut CtxUTxO Era)
headUTxO, FanoutProgressDatum
$sel:progressDatum:PartialFanoutPlan :: PartialFanoutPlan -> FanoutProgressDatum
progressDatum :: FanoutProgressDatum
progressDatum, HydraAccumulator
$sel:fullAccumulator:PartialFanoutPlan :: PartialFanoutPlan -> HydraAccumulator
fullAccumulator :: HydraAccumulator
fullAccumulator, [(TxIn, TxOut CtxUTxO Era)]
$sel:orderedRemaining:PartialFanoutPlan :: PartialFanoutPlan -> [(TxIn, TxOut CtxUTxO Era)]
orderedRemaining :: [(TxIn, TxOut CtxUTxO Era)]
orderedRemaining} = PartialFanoutPlan
plan

  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, which is exactly the set the
  -- FanoutProgress datum commits to.
  UTxO ->
  -- | Contestation deadline as SlotNo
  SlotNo ->
  Either PartialFanoutError Tx
finalPartialFanout :: ChainContext
-> UTxO Era
-> TxIn
-> UTxO Era
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO Era
spendableUTxO TxIn
seedTxIn UTxO Era
utxoToDistribute SlotNo
deadlineSlotNo = do
  (TxIn, TxOut CtxUTxO Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO Era -> Maybe (TxIn, TxOut CtxUTxO Era)
forall era.
(TxOut CtxUTxO era -> Bool)
-> UTxO era -> Maybe (TxIn, TxOut CtxUTxO era)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
Head.validatorScript) (PolicyId -> UTxO Era -> UTxO Era
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO Era
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO Era)
-> PartialFanoutError
-> Either PartialFanoutError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> PartialFanoutError
CannotFindHeadOutput
  State
headState <- (TxIn, TxOut CtxUTxO Era) -> Either PartialFanoutError State
readHeadState (TxIn, TxOut CtxUTxO Era)
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
  -- The accumulator verified against the datum here is the one the membership
  -- proof is built against, rather than a second build over the same set.
  HydraAccumulator
fullAccumulator <- FanoutProgressDatum
-> UTxO Era -> Either PartialFanoutError HydraAccumulator
buildAndVerifyAccumulator FanoutProgressDatum
progressDatum UTxO Era
utxoToDistribute
  (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 Era
-> HydraAccumulator
-> (TxIn, TxOut CtxUTxO Era)
-> SlotNo
-> PlutusScript PlutusScriptV3
-> Either Text Tx
finalPartialFanoutTx
      ScriptRegistry
scriptRegistry
      UTxO Era
utxoToDistribute
      HydraAccumulator
fullAccumulator
      (TxIn, TxOut CtxUTxO Era)
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 Era) -> Either PartialFanoutError State
readHeadState (TxIn
_, TxOut CtxUTxO Era
headOutput) = do
  HashableScriptData
headDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO Era
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 Era -> Either PartialFanoutError HydraAccumulator
buildAndVerifyAccumulator FanoutProgressDatum
progressDatum UTxO Era
utxo = do
  let acc :: HydraAccumulator
acc = forall tx. IsTx tx => UTxOType tx -> HydraAccumulator
Accumulator.buildFromUTxO @Tx UTxOType Tx
UTxO Era
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 Era -> UTxO Era
utxoOfThisHead PolicyId
policy = (TxOut CtxUTxO Era -> Bool) -> UTxO Era -> UTxO Era
forall era. (TxOut CtxUTxO era -> Bool) -> UTxO era -> UTxO era
UTxO.filter TxOut CtxUTxO Era -> Bool
hasHeadToken
 where
  hasHeadToken :: TxOut CtxUTxO Era -> Bool
hasHeadToken =
    Maybe (AssetId, Quantity) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (AssetId, Quantity) -> Bool)
-> (TxOut CtxUTxO Era -> Maybe (AssetId, Quantity))
-> TxOut CtxUTxO Era
-> 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 Era -> [(AssetId, Quantity)])
-> TxOut CtxUTxO Era
-> 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 Era -> Value)
-> TxOut CtxUTxO Era
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> 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)