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

-- | Contains the a state-ful 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 Data.Map qualified as Map
import Data.Maybe (fromJust)
import Hydra.Cardano.Api (
  AssetId (..),
  AssetName (AssetName),
  ChainPoint (..),
  CtxUTxO,
  Key (SigningKey, VerificationKey, verificationKeyHash),
  KeyWitnessInCtx (..),
  NetworkId (Mainnet, Testnet),
  NetworkMagic (NetworkMagic),
  PaymentKey,
  PlutusScriptV2,
  PolicyId,
  Quantity (..),
  SerialiseAsRawBytes (serialiseToRawBytes),
  SlotNo (SlotNo),
  Tx,
  TxIn,
  TxOut,
  UTxO,
  UTxO' (UTxO),
  WitCtxTxIn,
  Witness,
  chainPointToSlotNo,
  fromPlutusScript,
  fromScriptData,
  genTxIn,
  isScriptTxOut,
  modifyTxOutValue,
  selectAsset,
  selectLovelace,
  toTxContext,
  txIns',
  txOutReferenceScript,
  txOutScriptData,
  txOutValue,
  valueFromList,
  valueToList,
  pattern ByronAddressInEra,
  pattern KeyWitness,
  pattern ReferenceScript,
  pattern ReferenceScriptNone,
  pattern ShelleyAddressInEra,
  pattern TxOut,
 )
import Hydra.Chain (
  ChainStateType,
  HeadParameters (..),
  IsChainState (..),
  OnChainTx (..),
  PostTxError (..),
  maxMainnetLovelace,
  maximumNumberOfParties,
 )
import Hydra.Chain.Direct.ScriptRegistry (
  ScriptRegistry (..),
  genScriptRegistry,
  registryUTxO,
 )
import Hydra.Chain.Direct.TimeHandle (PointInTime)
import Hydra.Chain.Direct.Tx (
  AbortTxError (..),
  CloseObservation (..),
  CloseTxError (..),
  ClosedThreadOutput (..),
  ClosingSnapshot (..),
  CollectComObservation (..),
  CommitObservation (..),
  ContestTxError (..),
  FanoutTxError (..),
  InitObservation (..),
  InitialThreadOutput (..),
  NotAnInitReason,
  OpenThreadOutput (..),
  UTxOHash (UTxOHash),
  abortTx,
  closeTx,
  collectComTx,
  commitTx,
  contestTx,
  fanoutTx,
  headIdToPolicyId,
  initTx,
  observeCloseTx,
  observeCollectComTx,
  observeCommitTx,
  observeInitTx,
  txInToHeadSeed,
  verificationKeyToOnChainId,
 )
import Hydra.ContestationPeriod (ContestationPeriod, toChain)
import Hydra.ContestationPeriod qualified as ContestationPeriod
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Contract.Initial qualified as Initial
import Hydra.Crypto (HydraKey)
import Hydra.HeadId (HeadId (..))
import Hydra.Ledger (ChainSlot (ChainSlot), IsTx (hashUTxO))
import Hydra.Ledger.Cardano (genOneUTxOFor, genUTxOAdaOnlyOfSize, genVerificationKey)
import Hydra.Ledger.Cardano.Evaluate (genPointInTimeBefore, genValidityBoundsFromContestationPeriod, slotLength, systemStart)
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime)
import Hydra.OnChainId (OnChainId)
import Hydra.Party (Party, deriveParty, partyToChain)
import Hydra.Plutus.Extras (posixToUTCTime)
import Hydra.Snapshot (
  ConfirmedSnapshot (..),
  Snapshot (..),
  SnapshotNumber,
  genConfirmedSnapshot,
  getSnapshot,
 )
import Test.QuickCheck (choose, frequency, oneof, vector)
import Test.QuickCheck.Gen (elements)
import Test.QuickCheck.Modifiers (Positive (Positive))

-- | 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).
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 Arbitrary ChainStateAt where
  arbitrary :: Gen ChainStateAt
arbitrary = Gen ChainStateAt
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: ChainStateAt -> [ChainStateAt]
shrink = ChainStateAt -> [ChainStateAt]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance IsChainState Tx where
  type ChainStateType Tx = ChainStateAt

  chainStateSlot :: ChainStateType Tx -> ChainSlot
chainStateSlot ChainStateAt{Maybe ChainPoint
$sel:recordedAt:ChainStateAt :: ChainStateAt -> Maybe ChainPoint
recordedAt :: Maybe ChainPoint
recordedAt} =
    ChainSlot
-> (ChainPoint -> ChainSlot) -> Maybe ChainPoint -> ChainSlot
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Natural -> ChainSlot
ChainSlot Natural
0) ChainPoint -> ChainSlot
chainSlotFromPoint Maybe ChainPoint
recordedAt

-- | 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

-- | A definition of all transitions between 'ChainState's. Enumerable and
-- bounded to be used as labels for checking coverage.
data ChainTransition
  = Init
  | Abort
  | Commit
  | Collect
  | Close
  | Contest
  | Fanout
  deriving stock (ChainTransition -> ChainTransition -> Bool
(ChainTransition -> ChainTransition -> Bool)
-> (ChainTransition -> ChainTransition -> Bool)
-> Eq ChainTransition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainTransition -> ChainTransition -> Bool
== :: ChainTransition -> ChainTransition -> Bool
$c/= :: ChainTransition -> ChainTransition -> Bool
/= :: ChainTransition -> ChainTransition -> Bool
Eq, Int -> ChainTransition -> ShowS
[ChainTransition] -> ShowS
ChainTransition -> String
(Int -> ChainTransition -> ShowS)
-> (ChainTransition -> String)
-> ([ChainTransition] -> ShowS)
-> Show ChainTransition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainTransition -> ShowS
showsPrec :: Int -> ChainTransition -> ShowS
$cshow :: ChainTransition -> String
show :: ChainTransition -> String
$cshowList :: [ChainTransition] -> ShowS
showList :: [ChainTransition] -> ShowS
Show, Int -> ChainTransition
ChainTransition -> Int
ChainTransition -> [ChainTransition]
ChainTransition -> ChainTransition
ChainTransition -> ChainTransition -> [ChainTransition]
ChainTransition
-> ChainTransition -> ChainTransition -> [ChainTransition]
(ChainTransition -> ChainTransition)
-> (ChainTransition -> ChainTransition)
-> (Int -> ChainTransition)
-> (ChainTransition -> Int)
-> (ChainTransition -> [ChainTransition])
-> (ChainTransition -> ChainTransition -> [ChainTransition])
-> (ChainTransition -> ChainTransition -> [ChainTransition])
-> (ChainTransition
    -> ChainTransition -> ChainTransition -> [ChainTransition])
-> Enum ChainTransition
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ChainTransition -> ChainTransition
succ :: ChainTransition -> ChainTransition
$cpred :: ChainTransition -> ChainTransition
pred :: ChainTransition -> ChainTransition
$ctoEnum :: Int -> ChainTransition
toEnum :: Int -> ChainTransition
$cfromEnum :: ChainTransition -> Int
fromEnum :: ChainTransition -> Int
$cenumFrom :: ChainTransition -> [ChainTransition]
enumFrom :: ChainTransition -> [ChainTransition]
$cenumFromThen :: ChainTransition -> ChainTransition -> [ChainTransition]
enumFromThen :: ChainTransition -> ChainTransition -> [ChainTransition]
$cenumFromTo :: ChainTransition -> ChainTransition -> [ChainTransition]
enumFromTo :: ChainTransition -> ChainTransition -> [ChainTransition]
$cenumFromThenTo :: ChainTransition
-> ChainTransition -> ChainTransition -> [ChainTransition]
enumFromThenTo :: ChainTransition
-> ChainTransition -> ChainTransition -> [ChainTransition]
Enum, ChainTransition
ChainTransition -> ChainTransition -> Bounded ChainTransition
forall a. a -> a -> Bounded a
$cminBound :: ChainTransition
minBound :: ChainTransition
$cmaxBound :: ChainTransition
maxBound :: ChainTransition
Bounded)

-- | 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
  | Initial InitialState
  | 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)
  deriving anyclass ([ChainState] -> Value
[ChainState] -> Encoding
ChainState -> Bool
ChainState -> Value
ChainState -> Encoding
(ChainState -> Value)
-> (ChainState -> Encoding)
-> ([ChainState] -> Value)
-> ([ChainState] -> Encoding)
-> (ChainState -> Bool)
-> ToJSON ChainState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ChainState -> Value
toJSON :: ChainState -> Value
$ctoEncoding :: ChainState -> Encoding
toEncoding :: ChainState -> Encoding
$ctoJSONList :: [ChainState] -> Value
toJSONList :: [ChainState] -> Value
$ctoEncodingList :: [ChainState] -> Encoding
toEncodingList :: [ChainState] -> Encoding
$comitField :: ChainState -> Bool
omitField :: ChainState -> Bool
ToJSON, Maybe ChainState
Value -> Parser [ChainState]
Value -> Parser ChainState
(Value -> Parser ChainState)
-> (Value -> Parser [ChainState])
-> Maybe ChainState
-> FromJSON ChainState
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ChainState
parseJSON :: Value -> Parser ChainState
$cparseJSONList :: Value -> Parser [ChainState]
parseJSONList :: Value -> Parser [ChainState]
$comittedField :: Maybe ChainState
omittedField :: Maybe ChainState
FromJSON)

instance Arbitrary ChainState where
  arbitrary :: Gen ChainState
arbitrary = Gen ChainState
genChainState
  shrink :: ChainState -> [ChainState]
shrink = ChainState -> [ChainState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance HasKnownUTxO ChainState where
  getKnownUTxO :: ChainState -> UTxO
  getKnownUTxO :: ChainState -> UTxO
getKnownUTxO = \case
    ChainState
Idle -> UTxO
forall a. Monoid a => a
mempty
    Initial InitialState
st -> InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
st
    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)
  deriving anyclass ([ChainContext] -> Value
[ChainContext] -> Encoding
ChainContext -> Bool
ChainContext -> Value
ChainContext -> Encoding
(ChainContext -> Value)
-> (ChainContext -> Encoding)
-> ([ChainContext] -> Value)
-> ([ChainContext] -> Encoding)
-> (ChainContext -> Bool)
-> ToJSON ChainContext
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ChainContext -> Value
toJSON :: ChainContext -> Value
$ctoEncoding :: ChainContext -> Encoding
toEncoding :: ChainContext -> Encoding
$ctoJSONList :: [ChainContext] -> Value
toJSONList :: [ChainContext] -> Value
$ctoEncodingList :: [ChainContext] -> Encoding
toEncodingList :: [ChainContext] -> Encoding
$comitField :: ChainContext -> Bool
omitField :: ChainContext -> Bool
ToJSON, Maybe ChainContext
Value -> Parser [ChainContext]
Value -> Parser ChainContext
(Value -> Parser ChainContext)
-> (Value -> Parser [ChainContext])
-> Maybe ChainContext
-> FromJSON ChainContext
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ChainContext
parseJSON :: Value -> Parser ChainContext
$cparseJSONList :: Value -> Parser [ChainContext]
parseJSONList :: Value -> Parser [ChainContext]
$comittedField :: Maybe ChainContext
omittedField :: Maybe ChainContext
FromJSON)

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

instance Arbitrary ChainContext where
  arbitrary :: Gen ChainContext
arbitrary = do
    NetworkId
networkId <- NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId)
-> (Word32 -> NetworkMagic) -> Word32 -> NetworkId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkId) -> Gen Word32 -> Gen NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
    VerificationKey PaymentKey
ownVerificationKey <- Gen (VerificationKey PaymentKey)
genVerificationKey
    [Party]
otherParties <- Gen [Party]
forall a. Arbitrary a => Gen a
arbitrary
    Party
ownParty <- [Party] -> Gen Party
forall a. [a] -> Gen a
elements [Party]
otherParties
    ScriptRegistry
scriptRegistry <- Gen ScriptRegistry
genScriptRegistry
    ChainContext -> Gen ChainContext
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ChainContext
        { NetworkId
$sel:networkId:ChainContext :: NetworkId
networkId :: NetworkId
networkId
        , VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey
        , Party
$sel:ownParty:ChainContext :: Party
ownParty :: Party
ownParty
        , ScriptRegistry
$sel:scriptRegistry:ChainContext :: ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry
        }

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

instance Arbitrary InitialState where
  arbitrary :: Gen InitialState
arbitrary = do
    HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
    (ChainContext, InitialState) -> InitialState
forall a b. (a, b) -> b
snd ((ChainContext, InitialState) -> InitialState)
-> Gen (ChainContext, InitialState) -> Gen InitialState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx

  shrink :: InitialState -> [InitialState]
shrink = InitialState -> [InitialState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance HasKnownUTxO InitialState where
  getKnownUTxO :: InitialState -> UTxO
getKnownUTxO InitialState
st =
    Map TxIn (TxOut CtxUTxO Era) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO)
-> Map TxIn (TxOut CtxUTxO Era) -> UTxO
forall a b. (a -> b) -> a -> b
$
      [(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$
        (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO (TxIn, TxOut CtxUTxO Era)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. a -> [a] -> [a]
: [(TxIn, TxOut CtxUTxO Era)]
initialCommits [(TxIn, TxOut CtxUTxO Era)]
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Semigroup a => a -> a -> a
<> [(TxIn, TxOut CtxUTxO Era)]
initialInitials
   where
    InitialState
      { $sel:initialThreadOutput:InitialState :: InitialState -> InitialThreadOutput
initialThreadOutput = InitialThreadOutput{(TxIn, TxOut CtxUTxO Era)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:initialThreadUTxO:InitialThreadOutput :: InitialThreadOutput -> (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO}
      , [(TxIn, TxOut CtxUTxO Era)]
$sel:initialInitials:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialInitials :: [(TxIn, TxOut CtxUTxO Era)]
initialInitials
      , [(TxIn, TxOut CtxUTxO Era)]
$sel:initialCommits:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialCommits :: [(TxIn, TxOut CtxUTxO Era)]
initialCommits
      } = InitialState
st

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

instance Arbitrary OpenState where
  arbitrary :: Gen OpenState
arbitrary = do
    HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
    (UTxO, OpenState) -> OpenState
forall a b. (a, b) -> b
snd ((UTxO, OpenState) -> OpenState)
-> Gen (UTxO, OpenState) -> Gen OpenState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx

  shrink :: OpenState -> [OpenState]
shrink = OpenState -> [OpenState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance HasKnownUTxO OpenState where
  getKnownUTxO :: OpenState -> UTxO
getKnownUTxO OpenState
st =
    (TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO Era)
openThreadUTxO
   where
    OpenState
      { $sel:openThreadOutput:OpenState :: OpenState -> OpenThreadOutput
openThreadOutput = OpenThreadOutput{(TxIn, TxOut CtxUTxO Era)
openThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:openThreadUTxO:OpenThreadOutput :: OpenThreadOutput -> (TxIn, TxOut CtxUTxO Era)
openThreadUTxO}
      } = OpenState
st

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

instance Arbitrary ClosedState where
  arbitrary :: Gen ClosedState
arbitrary = do
    -- XXX: Untangle the whole generator mess here
    (HydraContext
_, ClosedState
st, Tx
_) <- Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx Int
maxGenParties Int
maxGenAssets
    ClosedState -> Gen ClosedState
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosedState
st

  shrink :: ClosedState -> [ClosedState]
shrink = ClosedState -> [ClosedState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance HasKnownUTxO ClosedState where
  getKnownUTxO :: ClosedState -> UTxO
getKnownUTxO ClosedState
st =
    (TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO
   where
    ClosedState
      { $sel:closedThreadOutput:ClosedState :: ClosedState -> ClosedThreadOutput
closedThreadOutput = ClosedThreadOutput{(TxIn, TxOut CtxUTxO Era)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:closedThreadUTxO:ClosedThreadOutput :: ClosedThreadOutput -> (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO}
      } = ClosedState
st

-- * Constructing transactions

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

-- | Construct a commit transaction based on known, spendable UTxO and some
-- arbitrary UTxOs to commit. This does look for "our initial output" to spend
-- and check the given 'UTxO' to be compatible. Hence, this function does fail
-- if already committed or if the head is not initializing.
--
-- NOTE: This version of 'commit' does only commit outputs which are held by
-- payment keys. For a variant which supports committing scripts, see `commit'`.
commit ::
  ChainContext ->
  HeadId ->
  -- | Spendable 'UTxO'
  UTxO ->
  -- | 'UTxO' to commit. All outputs are assumed to be owned by public keys.
  UTxO ->
  Either (PostTxError Tx) Tx
commit :: ChainContext
-> HeadId -> UTxO -> UTxO -> Either (PostTxError Tx) Tx
commit ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO
utxoToCommit =
  ChainContext
-> HeadId
-> UTxO
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO (UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
 -> Either (PostTxError Tx) Tx)
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
forall a b. (a -> b) -> a -> b
$ UTxO
utxoToCommit UTxO
-> (TxOut CtxUTxO Era -> (TxOut CtxUTxO Era, Witness WitCtxTxIn))
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)

-- | Construct a commit transaction based on known, spendable UTxO and some
-- arbitrary UTxOs to commit. This does look for "our initial output" to spend
-- and check the given 'UTxO' to be compatible. Hence, this function does fail
-- if already committed or if the head is not initializing.
--
-- NOTE: A simpler variant only supporting pubkey outputs is 'commit'.
commit' ::
  ChainContext ->
  HeadId ->
  -- | Spendable 'UTxO'
  UTxO ->
  -- | 'UTxO' to commit, along with witnesses to spend them.
  UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) ->
  Either (PostTxError Tx) Tx
commit' :: ChainContext
-> HeadId
-> UTxO
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
utxoToCommit = do
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId
-> PostTxError Tx -> Either (PostTxError Tx) PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadId{HeadId
headId :: HeadId
$sel:headId:NoSeedInput :: HeadId
headId}
  (TxIn
i, TxOut CtxUTxO Era
o) <- PolicyId -> Maybe (TxIn, TxOut CtxUTxO Era)
ownInitial PolicyId
pid Maybe (TxIn, TxOut CtxUTxO Era)
-> PostTxError Tx
-> Either (PostTxError Tx) (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> CannotFindOwnInitial{$sel:knownUTxO:NoSeedInput :: UTxOType Tx
knownUTxO = UTxO
UTxOType Tx
spendableUTxO}
  let utxo :: UTxO
utxo = (TxOut CtxUTxO Era, Witness WitCtxTxIn) -> TxOut CtxUTxO Era
forall a b. (a, b) -> a
fst ((TxOut CtxUTxO Era, Witness WitCtxTxIn) -> TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn) -> UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
utxoToCommit
  UTxO -> Either (PostTxError Tx) ()
rejectByronAddress UTxO
utxo
  UTxO -> Either (PostTxError Tx) ()
rejectReferenceScripts UTxO
utxo
  NetworkId -> UTxO -> Either (PostTxError Tx) ()
rejectMoreThanMainnetLimit NetworkId
networkId UTxO
utxo
  Tx -> Either (PostTxError Tx) Tx
forall a. a -> Either (PostTxError Tx) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either (PostTxError Tx) Tx)
-> Tx -> Either (PostTxError Tx) Tx
forall a b. (a -> b) -> a -> b
$ NetworkId
-> ScriptRegistry
-> HeadId
-> Party
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> (TxIn, TxOut CtxUTxO Era, Hash PaymentKey)
-> Tx
commitTx NetworkId
networkId ScriptRegistry
scriptRegistry HeadId
headId Party
ownParty UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
utxoToCommit (TxIn
i, TxOut CtxUTxO Era
o, Hash PaymentKey
vkh)
 where
  ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId, Party
$sel:ownParty:ChainContext :: ChainContext -> Party
ownParty :: Party
ownParty, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry, VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey} = ChainContext
ctx

  vkh :: Hash PaymentKey
vkh = VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
ownVerificationKey

  ownInitial :: PolicyId -> Maybe (TxIn, TxOut CtxUTxO Era)
ownInitial PolicyId
pid =
    (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PolicyId -> Value -> Bool
hasMatchingPT PolicyId
pid (Value -> Bool)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) UTxO
spendableUTxO

  hasMatchingPT :: PolicyId -> Value -> Bool
hasMatchingPT PolicyId
pid Value
val =
    Value -> AssetId -> Quantity
selectAsset Value
val (PolicyId -> AssetName -> AssetId
AssetId PolicyId
pid (ByteString -> AssetName
AssetName (Hash PaymentKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes Hash PaymentKey
vkh))) Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1

rejectByronAddress :: UTxO -> Either (PostTxError Tx) ()
rejectByronAddress :: UTxO -> Either (PostTxError Tx) ()
rejectByronAddress UTxO
u = do
  UTxO
-> (TxOut CtxUTxO Era -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ UTxO
u ((TxOut CtxUTxO Era -> Either (PostTxError Tx) ())
 -> Either (PostTxError Tx) ())
-> (TxOut CtxUTxO Era -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$ \case
    (TxOut (ByronAddressInEra Address ByronAddr
addr) Value
_ TxOutDatum CtxUTxO
_ ReferenceScript
_) ->
      PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left (Address ByronAddr -> PostTxError Tx
forall tx. Address ByronAddr -> PostTxError tx
UnsupportedLegacyOutput Address ByronAddr
addr)
    (TxOut ShelleyAddressInEra{} Value
_ TxOutDatum CtxUTxO
_ ReferenceScript
_) ->
      () -> Either (PostTxError Tx) ()
forall a b. b -> Either a b
Right ()

rejectReferenceScripts :: UTxO -> Either (PostTxError Tx) ()
rejectReferenceScripts :: UTxO -> Either (PostTxError Tx) ()
rejectReferenceScripts UTxO
u =
  Bool -> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((TxOut CtxUTxO Era -> Bool) -> UTxO -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TxOut CtxUTxO Era -> Bool
forall {ctx}. TxOut ctx -> Bool
hasReferenceScript UTxO
u) (Either (PostTxError Tx) () -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
    PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left PostTxError Tx
forall tx. PostTxError tx
CannotCommitReferenceScript
 where
  hasReferenceScript :: TxOut ctx -> Bool
hasReferenceScript TxOut ctx
out =
    case TxOut ctx -> ReferenceScript
forall ctx. TxOut ctx -> ReferenceScript
txOutReferenceScript TxOut ctx
out of
      ReferenceScript{} -> Bool
True
      ReferenceScript
ReferenceScriptNone -> Bool
False

-- Rejects outputs with more than 'maxMainnetLovelace' lovelace on mainnet
-- NOTE: Remove this limit once we have more experiments on mainnet.
rejectMoreThanMainnetLimit :: NetworkId -> UTxO -> Either (PostTxError Tx) ()
rejectMoreThanMainnetLimit :: NetworkId -> UTxO -> Either (PostTxError Tx) ()
rejectMoreThanMainnetLimit NetworkId
network UTxO
u = do
  Bool -> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NetworkId
network NetworkId -> NetworkId -> Bool
forall a. Eq a => a -> a -> Bool
== NetworkId
Mainnet Bool -> Bool -> Bool
&& Coin
lovelaceAmt Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
maxMainnetLovelace) (Either (PostTxError Tx) () -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
    PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left (PostTxError Tx -> Either (PostTxError Tx) ())
-> PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
      Coin -> Coin -> PostTxError Tx
forall tx. Coin -> Coin -> PostTxError tx
CommittedTooMuchADAForMainnet Coin
lovelaceAmt Coin
maxMainnetLovelace
 where
  lovelaceAmt :: Coin
lovelaceAmt = (TxOut CtxUTxO Era -> Coin) -> UTxO -> Coin
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) UTxO
u

-- | Construct a abort transaction based on known, spendable UTxO. This function
-- looks for head, initial and commit outputs to spend and it will fail if we
-- can't find the head output.
abort ::
  ChainContext ->
  -- | Seed TxIn
  TxIn ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  -- | Committed UTxOs to reimburse.
  UTxO ->
  Either AbortTxError Tx
abort :: ChainContext -> TxIn -> UTxO -> UTxO -> Either AbortTxError Tx
abort ChainContext
ctx TxIn
seedTxIn UTxO
spendableUTxO UTxO
committedUTxO = do
  (TxIn, TxOut CtxUTxO Era)
headUTxO <-
    Either AbortTxError (TxIn, TxOut CtxUTxO Era)
-> ((TxIn, TxOut CtxUTxO Era)
    -> Either AbortTxError (TxIn, TxOut CtxUTxO Era))
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AbortTxError -> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall a b. a -> Either a b
Left AbortTxError
CannotFindHeadOutputToAbort) (TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall a. a -> Either AbortTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TxIn, TxOut CtxUTxO Era)
 -> Either AbortTxError (TxIn, TxOut CtxUTxO Era))
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$
      (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) UTxO
utxoOfThisHead'

  UTxO
-> ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, TxOut CtxUTxO Era)
-> PlutusScript PlutusScriptV2
-> Map TxIn (TxOut CtxUTxO Era)
-> Map TxIn (TxOut CtxUTxO Era)
-> Either AbortTxError Tx
abortTx UTxO
committedUTxO ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey (TxIn, TxOut CtxUTxO Era)
headUTxO PlutusScript PlutusScriptV2
headTokenScript Map TxIn (TxOut CtxUTxO Era)
initials Map TxIn (TxOut CtxUTxO Era)
commits
 where
  utxoOfThisHead' :: UTxO
utxoOfThisHead' = PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
spendableUTxO

  initials :: Map TxIn (TxOut CtxUTxO Era)
initials =
    UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (UTxO -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
initialScript) UTxO
utxoOfThisHead'

  commits :: Map TxIn (TxOut CtxUTxO Era)
commits =
    UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (UTxO -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
commitScript) UTxO
utxoOfThisHead'

  commitScript :: PlutusScript PlutusScriptV2
commitScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Commit.validatorScript

  headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript

  initialScript :: PlutusScript PlutusScriptV2
initialScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Initial.validatorScript

  headTokenScript :: PlutusScript PlutusScriptV2
headTokenScript = TxIn -> PlutusScript PlutusScriptV2
mkHeadTokenScript TxIn
seedTxIn

  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 CollectTxError
  = InvalidHeadIdInCollect {CollectTxError -> HeadId
headId :: HeadId}
  | CannotFindHeadOutputToCollect
  deriving stock (Int -> CollectTxError -> ShowS
[CollectTxError] -> ShowS
CollectTxError -> String
(Int -> CollectTxError -> ShowS)
-> (CollectTxError -> String)
-> ([CollectTxError] -> ShowS)
-> Show CollectTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CollectTxError -> ShowS
showsPrec :: Int -> CollectTxError -> ShowS
$cshow :: CollectTxError -> String
show :: CollectTxError -> String
$cshowList :: [CollectTxError] -> ShowS
showList :: [CollectTxError] -> ShowS
Show)

-- | Construct a collect transaction based on known, spendable UTxO. This
-- function looks for head output and commit outputs to spend and it will fail
-- if we can't find the head output.
collect ::
  ChainContext ->
  HeadId ->
  HeadParameters ->
  -- | UTxO to be used to collect.
  -- Should match whatever is recorded in the commit inputs.
  UTxO ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  Either CollectTxError Tx
collect :: ChainContext
-> HeadId
-> HeadParameters
-> UTxO
-> UTxO
-> Either CollectTxError Tx
collect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
utxoToCollect UTxO
spendableUTxO = do
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> CollectTxError -> Either CollectTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInCollect{HeadId
$sel:headId:InvalidHeadIdInCollect :: HeadId
headId :: HeadId
headId}
  let utxoOfThisHead' :: UTxO
utxoOfThisHead' = PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO
  (TxIn, TxOut CtxUTxO Era)
headUTxO <- (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) UTxO
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO Era)
-> CollectTxError
-> Either CollectTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> CollectTxError
CannotFindHeadOutputToCollect
  let commits :: Map TxIn (TxOut CtxUTxO Era)
commits = UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (UTxO -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
commitScript) UTxO
utxoOfThisHead'
  Tx -> Either CollectTxError Tx
forall a. a -> Either CollectTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either CollectTxError Tx) -> Tx -> Either CollectTxError Tx
forall a b. (a -> b) -> a -> b
$
    NetworkId
-> ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> HeadParameters
-> (TxIn, TxOut CtxUTxO Era)
-> Map TxIn (TxOut CtxUTxO Era)
-> UTxO
-> Tx
collectComTx NetworkId
networkId ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey HeadId
headId HeadParameters
headParameters (TxIn, TxOut CtxUTxO Era)
headUTxO Map TxIn (TxOut CtxUTxO Era)
commits UTxO
utxoToCollect
 where
  headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript

  commitScript :: PlutusScript PlutusScriptV2
commitScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Commit.validatorScript

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

-- | Construct a close transaction based on the 'OpenState' and a confirmed
-- snapshot.
--  - 'SlotNo' parameter will be used as the 'Tx' lower bound.
--  - 'PointInTime' parameter will be used as an upper validity bound and
--       will define the start of the contestation period.
-- NB: lower and upper bound slot difference should not exceed contestation period
close ::
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  HeadId ->
  HeadParameters ->
  ConfirmedSnapshot Tx ->
  -- | 'Tx' validity lower bound
  SlotNo ->
  -- | 'Tx' validity upper bound
  PointInTime ->
  Either CloseTxError Tx
close :: ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod} 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
headId :: HeadId
$sel:headId:InvalidHeadIdInClose :: HeadId
headId}
  (TxIn, TxOut CtxUTxO Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
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: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
          }
  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
-> ClosingSnapshot
-> SlotNo
-> PointInTime
-> OpenThreadOutput
-> HeadId
-> Tx
closeTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey ClosingSnapshot
closingSnapshot SlotNo
startSlotNo PointInTime
pointInTime OpenThreadOutput
openThreadOutput HeadId
headId
 where
  headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript

  closingSnapshot :: ClosingSnapshot
closingSnapshot = case ConfirmedSnapshot Tx
confirmedSnapshot of
    InitialSnapshot{UTxOType Tx
initialUTxO :: UTxOType Tx
$sel:initialUTxO:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> UTxOType tx
initialUTxO} -> CloseWithInitialSnapshot{$sel:openUtxoHash:CloseWithInitialSnapshot :: UTxOHash
openUtxoHash = ByteString -> UTxOHash
UTxOHash (ByteString -> UTxOHash) -> ByteString -> UTxOHash
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxOType Tx
initialUTxO}
    ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{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}, MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures} ->
      CloseWithConfirmedSnapshot
        { $sel:snapshotNumber:CloseWithInitialSnapshot :: SnapshotNumber
snapshotNumber = SnapshotNumber
number
        , $sel:closeUtxoHash:CloseWithInitialSnapshot :: UTxOHash
closeUtxoHash = ByteString -> UTxOHash
UTxOHash (ByteString -> UTxOHash) -> ByteString -> UTxOHash
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxOType Tx
utxo
        , MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:CloseWithInitialSnapshot :: MultiSignature (Snapshot Tx)
signatures
        }

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

-- | 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 ->
  ConfirmedSnapshot Tx ->
  PointInTime ->
  Either ContestTxError Tx
contest :: ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot 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
headId :: HeadId
$sel:headId:InvalidHeadIdInContest :: HeadId
headId}
  (TxIn, TxOut CtxUTxO Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
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
checkHeadDatum (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
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> PointInTime
-> ClosedThreadOutput
-> HeadId
-> ContestationPeriod
-> Tx
contestTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey Snapshot Tx
sn MultiSignature (Snapshot Tx)
sigs PointInTime
pointInTime ClosedThreadOutput
closedThreadOutput HeadId
headId ContestationPeriod
contestationPeriod
 where
  checkHeadDatum :: (TxIn, TxOut CtxUTxO Era)
-> Either ContestTxError ClosedThreadOutput
checkHeadDatum 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
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext 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{[PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters, [Party]
parties :: [Party]
$sel:parties:Initial :: State -> [Party]
parties, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline} -> 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)
$sel:closedThreadUTxO:ClosedThreadOutput :: (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO :: (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
            }
      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
confirmedSnapshot of
      ConfirmedSnapshot{MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot Tx)
signatures} -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot, MultiSignature (Snapshot Tx)
signatures)
      ConfirmedSnapshot Tx
_ -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot, 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

  headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript

-- | 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 ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  Either FanoutTxError Tx
fanout :: ChainContext
-> UTxO -> TxIn -> UTxO -> SlotNo -> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo SlotNo
deadlineSlotNo = do
  (TxIn, TxOut CtxUTxO Era)
headUTxO <-
    (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
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)
forall {a} {era}.
(a, TxOut CtxUTxO era)
-> Either FanoutTxError (a, TxOut CtxUTxO era)
checkHeadDatum (TxIn, TxOut CtxUTxO Era)
headUTxO

  Tx -> Either FanoutTxError Tx
forall a. a -> Either FanoutTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either FanoutTxError Tx) -> Tx -> Either FanoutTxError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> UTxO
-> (TxIn, TxOut CtxUTxO Era)
-> SlotNo
-> PlutusScript PlutusScriptV2
-> Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO
utxo (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO SlotNo
deadlineSlotNo PlutusScript PlutusScriptV2
headTokenScript
 where
  headTokenScript :: PlutusScript PlutusScriptV2
headTokenScript = TxIn -> PlutusScript PlutusScriptV2
mkHeadTokenScript TxIn
seedTxIn

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

  headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript

  checkHeadDatum :: (a, TxOut CtxUTxO era)
-> Either FanoutTxError (a, TxOut CtxUTxO era)
checkHeadDatum headUTxO :: (a, TxOut CtxUTxO era)
headUTxO@(a
_, 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
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext 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{} -> (a, TxOut CtxUTxO era)
-> Either FanoutTxError (a, TxOut CtxUTxO era)
forall a. a -> Either FanoutTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, TxOut CtxUTxO era)
headUTxO
      State
_ -> FanoutTxError -> Either FanoutTxError (a, TxOut CtxUTxO era)
forall a b. a -> Either a b
Left FanoutTxError
WrongDatumInFanout

-- * Helpers

utxoOfThisHead :: PolicyId -> UTxO -> UTxO
utxoOfThisHead :: PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
policy = (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
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)]
valueToList (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

-- * Observing Transitions

-- ** IdleState transitions

-- TODO: This function is not really used anymore (only from
-- 'unsafeObserveInit'). In general, most functions here are actually not used
-- from the "production code", but only to generate test cases and benchmarks.

-- | Observe an init transition using a 'InitialState' and 'observeInitTx'.
observeInit ::
  ChainContext ->
  [VerificationKey PaymentKey] ->
  Tx ->
  Either NotAnInitReason (OnChainTx Tx, InitialState)
observeInit :: ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> Either NotAnInitReason (OnChainTx Tx, InitialState)
observeInit ChainContext
_ctx [VerificationKey PaymentKey]
_allVerificationKeys Tx
tx = do
  InitObservation
observation <- Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx
  (OnChainTx Tx, InitialState)
-> Either NotAnInitReason (OnChainTx Tx, InitialState)
forall a. a -> Either NotAnInitReason a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InitObservation -> OnChainTx Tx
forall {tx}. InitObservation -> OnChainTx tx
toEvent InitObservation
observation, InitObservation -> InitialState
toState InitObservation
observation)
 where
  toEvent :: InitObservation -> OnChainTx tx
toEvent InitObservation{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:InitObservation :: InitObservation -> ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:InitObservation :: InitObservation -> [Party]
parties, HeadId
headId :: HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId, TxIn
seedTxIn :: TxIn
$sel:seedTxIn:InitObservation :: InitObservation -> TxIn
seedTxIn, [OnChainId]
participants :: [OnChainId]
$sel:participants:InitObservation :: InitObservation -> [OnChainId]
participants} =
    OnInitTx
      { HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId
      , $sel:headSeed:OnInitTx :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed TxIn
seedTxIn
      , $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:HeadParameters :: [Party]
parties :: [Party]
parties}
      , [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants
      }

  toState :: InitObservation -> InitialState
toState InitObservation{(TxIn, TxOut CtxUTxO Era)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:initialThreadUTxO:InitObservation :: InitObservation -> (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO, [Party]
$sel:parties:InitObservation :: InitObservation -> [Party]
parties :: [Party]
parties, ContestationPeriod
$sel:contestationPeriod:InitObservation :: InitObservation -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [(TxIn, TxOut CtxUTxO Era)]
initials :: [(TxIn, TxOut CtxUTxO Era)]
$sel:initials:InitObservation :: InitObservation -> [(TxIn, TxOut CtxUTxO Era)]
initials, HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId :: HeadId
headId, TxIn
$sel:seedTxIn:InitObservation :: InitObservation -> TxIn
seedTxIn :: TxIn
seedTxIn} =
    InitialState
      { $sel:initialThreadOutput:InitialState :: InitialThreadOutput
initialThreadOutput =
          InitialThreadOutput
            { (TxIn, TxOut CtxUTxO Era)
$sel:initialThreadUTxO:InitialThreadOutput :: (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO
            , $sel:initialParties:InitialThreadOutput :: [Party]
initialParties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
            , $sel:initialContestationPeriod:InitialThreadOutput :: ContestationPeriod
initialContestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod
            }
      , $sel:initialInitials:InitialState :: [(TxIn, TxOut CtxUTxO Era)]
initialInitials = [(TxIn, TxOut CtxUTxO Era)]
initials
      , $sel:initialCommits:InitialState :: [(TxIn, TxOut CtxUTxO Era)]
initialCommits = [(TxIn, TxOut CtxUTxO Era)]
forall a. Monoid a => a
mempty
      , HeadId
$sel:headId:InitialState :: HeadId
headId :: HeadId
headId
      , TxIn
$sel:seedTxIn:InitialState :: TxIn
seedTxIn :: TxIn
seedTxIn
      }

-- ** InitialState transitions

-- | Observe an commit transition using a 'InitialState' and 'observeCommitTx'.
observeCommit ::
  ChainContext ->
  InitialState ->
  Tx ->
  Maybe (OnChainTx Tx, InitialState)
observeCommit :: ChainContext
-> InitialState -> Tx -> Maybe (OnChainTx Tx, InitialState)
observeCommit ChainContext
ctx InitialState
st Tx
tx = do
  let utxo :: UTxO
utxo = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
st
  CommitObservation
observation <- NetworkId -> UTxO -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO
utxo Tx
tx
  let CommitObservation{(TxIn, TxOut CtxUTxO Era)
commitOutput :: (TxIn, TxOut CtxUTxO Era)
$sel:commitOutput:CommitObservation :: CommitObservation -> (TxIn, TxOut CtxUTxO Era)
commitOutput, Party
party :: Party
$sel:party:CommitObservation :: CommitObservation -> Party
party, UTxO
committed :: UTxO
$sel:committed:CommitObservation :: CommitObservation -> UTxO
committed, $sel:headId:CommitObservation :: CommitObservation -> HeadId
headId = HeadId
commitHeadId} = CommitObservation
observation
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HeadId
commitHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId
  let event :: OnChainTx Tx
event = OnCommitTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, Party
party :: Party
$sel:party:OnInitTx :: Party
party, UTxO
UTxOType Tx
committed :: UTxO
$sel:committed:OnInitTx :: UTxOType Tx
committed}
  let st' :: InitialState
st' =
        InitialState
st
          { initialInitials =
              -- NOTE: A commit tx has been observed and thus we can
              -- remove all it's inputs from our tracked initials
              filter ((`notElem` txIns' tx) . fst) initialInitials
          , initialCommits =
              commitOutput : initialCommits
          }
  (OnChainTx Tx, InitialState) -> Maybe (OnChainTx Tx, InitialState)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainTx Tx
event, InitialState
st')
 where
  ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId} = ChainContext
ctx

  InitialState
    { [(TxIn, TxOut CtxUTxO Era)]
$sel:initialCommits:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialCommits :: [(TxIn, TxOut CtxUTxO Era)]
initialCommits
    , [(TxIn, TxOut CtxUTxO Era)]
$sel:initialInitials:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialInitials :: [(TxIn, TxOut CtxUTxO Era)]
initialInitials
    , HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId
    } = InitialState
st

-- | Observe an collect transition using a 'InitialState' and 'observeCollectComTx'.
-- This function checks the head id and ignores if not relevant.
observeCollect ::
  InitialState ->
  Tx ->
  Maybe (OnChainTx Tx, OpenState)
observeCollect :: InitialState -> Tx -> Maybe (OnChainTx Tx, OpenState)
observeCollect InitialState
st Tx
tx = do
  let utxo :: UTxO
utxo = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
st
  CollectComObservation
observation <- UTxO -> Tx -> Maybe CollectComObservation
observeCollectComTx UTxO
utxo Tx
tx
  let CollectComObservation{$sel:threadOutput:CollectComObservation :: CollectComObservation -> OpenThreadOutput
threadOutput = OpenThreadOutput
threadOutput, $sel:headId:CollectComObservation :: CollectComObservation -> HeadId
headId = HeadId
collectComHeadId, UTxOHash
utxoHash :: UTxOHash
$sel:utxoHash:CollectComObservation :: CollectComObservation -> UTxOHash
utxoHash} = CollectComObservation
observation
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
collectComHeadId)
  -- REVIEW: is it enough to pass here just the 'openThreadUTxO' or we need also
  -- the known utxo (getKnownUTxO st)?
  let event :: OnChainTx Tx
event = OnCollectComTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId}
  let st' :: OpenState
st' =
        OpenState
          { $sel:openThreadOutput:OpenState :: OpenThreadOutput
openThreadOutput = OpenThreadOutput
threadOutput
          , HeadId
$sel:headId:OpenState :: HeadId
headId :: HeadId
headId
          , TxIn
$sel:seedTxIn:OpenState :: TxIn
seedTxIn :: TxIn
seedTxIn
          , $sel:openUtxoHash:OpenState :: UTxOHash
openUtxoHash = UTxOHash
utxoHash
          }
  (OnChainTx Tx, OpenState) -> Maybe (OnChainTx Tx, OpenState)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainTx Tx
event, OpenState
st')
 where
  InitialState
    { HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId
    , TxIn
$sel:seedTxIn:InitialState :: InitialState -> TxIn
seedTxIn :: TxIn
seedTxIn
    } = InitialState
st

-- ** OpenState transitions

-- | Observe a close transition using a 'OpenState' and 'observeCloseTx'.
-- This function checks the head id and ignores if not relevant.
observeClose ::
  OpenState ->
  Tx ->
  Maybe (OnChainTx Tx, ClosedState)
observeClose :: OpenState -> Tx -> Maybe (OnChainTx Tx, ClosedState)
observeClose OpenState
st Tx
tx = do
  let utxo :: UTxO
utxo = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st
  CloseObservation
observation <- UTxO -> Tx -> Maybe CloseObservation
observeCloseTx UTxO
utxo Tx
tx
  let CloseObservation{ClosedThreadOutput
threadOutput :: ClosedThreadOutput
$sel:threadOutput:CloseObservation :: CloseObservation -> ClosedThreadOutput
threadOutput, $sel:headId:CloseObservation :: CloseObservation -> HeadId
headId = HeadId
closeObservationHeadId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:CloseObservation :: CloseObservation -> SnapshotNumber
snapshotNumber} = CloseObservation
observation
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
closeObservationHeadId)
  let ClosedThreadOutput{POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: ClosedThreadOutput -> POSIXTime
closedContestationDeadline :: POSIXTime
closedContestationDeadline} = ClosedThreadOutput
threadOutput
  let event :: OnChainTx Tx
event =
        OnCloseTx
          { $sel:headId:OnInitTx :: HeadId
headId = HeadId
closeObservationHeadId
          , SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber
          , $sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
closedContestationDeadline
          }
  let st' :: ClosedState
st' =
        ClosedState
          { $sel:closedThreadOutput:ClosedState :: ClosedThreadOutput
closedThreadOutput = ClosedThreadOutput
threadOutput
          , HeadId
$sel:headId:ClosedState :: HeadId
headId :: HeadId
headId
          , TxIn
$sel:seedTxIn:ClosedState :: TxIn
seedTxIn :: TxIn
seedTxIn
          }
  (OnChainTx Tx, ClosedState) -> Maybe (OnChainTx Tx, ClosedState)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainTx Tx
event, ClosedState
st')
 where
  OpenState
    { HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId
    , TxIn
$sel:seedTxIn:OpenState :: OpenState -> TxIn
seedTxIn :: TxIn
seedTxIn
    } = OpenState
st

-- * Generators

-- | Maximum number of parties used in the generators.
maxGenParties :: Int
maxGenParties :: Int
maxGenParties = Int
3

-- | Maximum number of assets (ADA or other tokens) used in the generators.
maxGenAssets :: Int
maxGenAssets :: Int
maxGenAssets = Int
70

-- | Generate a 'ChainState' within known limits above.
genChainState :: Gen ChainState
genChainState :: Gen ChainState
genChainState =
  [Gen ChainState] -> Gen ChainState
forall a. [Gen a] -> Gen a
oneof
    [ ChainState -> Gen ChainState
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainState
Idle
    , InitialState -> ChainState
Initial (InitialState -> ChainState) -> Gen InitialState -> Gen ChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen InitialState
forall a. Arbitrary a => Gen a
arbitrary
    , OpenState -> ChainState
Open (OpenState -> ChainState) -> Gen OpenState -> Gen ChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen OpenState
forall a. Arbitrary a => Gen a
arbitrary
    , ClosedState -> ChainState
Closed (ClosedState -> ChainState) -> Gen ClosedState -> Gen ChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ClosedState
forall a. Arbitrary a => Gen a
arbitrary
    ]

-- | Generate a 'ChainContext' and 'ChainState' within the known limits above, along with a
-- transaction that results in a transition away from it.
genChainStateWithTx :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genChainStateWithTx :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genChainStateWithTx =
  [Gen (ChainContext, ChainState, Tx, ChainTransition)]
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. [Gen a] -> Gen a
oneof
    [ Gen (ChainContext, ChainState, Tx, ChainTransition)
genInitWithState
    , Gen (ChainContext, ChainState, Tx, ChainTransition)
genAbortWithState
    , Gen (ChainContext, ChainState, Tx, ChainTransition)
genCommitWithState
    , Gen (ChainContext, ChainState, Tx, ChainTransition)
genCollectWithState
    , Gen (ChainContext, ChainState, Tx, ChainTransition)
genCloseWithState
    , Gen (ChainContext, ChainState, Tx, ChainTransition)
genContestWithState
    , Gen (ChainContext, ChainState, Tx, ChainTransition)
genFanoutWithState
    ]
 where
  genInitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
  genInitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genInitWithState = do
    HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
    ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
    TxIn
seedInput <- Gen TxIn
genTxIn
    let tx :: Tx
tx = ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx TxIn
seedInput (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
    (ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, ChainState
Idle, Tx
tx, ChainTransition
Init)

  genAbortWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
  genAbortWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genAbortWithState = do
    HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
    (ChainContext
cctx, InitialState
stInitial) <- HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx
    -- TODO: also generate sometimes aborts with utxo
    let utxo :: UTxO
utxo = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial
        InitialState{TxIn
$sel:seedTxIn:InitialState :: InitialState -> TxIn
seedTxIn :: TxIn
seedTxIn} = InitialState
stInitial
        tx :: Tx
tx = HasCallStack => ChainContext -> TxIn -> UTxO -> UTxO -> Tx
ChainContext -> TxIn -> UTxO -> UTxO -> Tx
unsafeAbort ChainContext
cctx TxIn
seedTxIn UTxO
utxo UTxO
forall a. Monoid a => a
mempty
    (ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState -> ChainState
Initial InitialState
stInitial, Tx
tx, ChainTransition
Abort)

  genCommitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
  genCommitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCommitWithState = do
    HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
    (ChainContext
cctx, InitialState
stInitial) <- HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx
    UTxO
utxo <- Gen UTxO
genCommit
    let InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = InitialState
stInitial
    let tx :: Tx
tx = HasCallStack => ChainContext -> HeadId -> UTxO -> UTxO -> Tx
ChainContext -> HeadId -> UTxO -> UTxO -> Tx
unsafeCommit ChainContext
cctx HeadId
headId (InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial) UTxO
utxo
    (ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState -> ChainState
Initial InitialState
stInitial, Tx
tx, ChainTransition
Commit)

  genCollectWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
  genCollectWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCollectWithState = do
    (ChainContext
ctx, [UTxO]
_, InitialState
st, Tx
tx) <- Gen (ChainContext, [UTxO], InitialState, Tx)
genCollectComTx
    (ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, InitialState -> ChainState
Initial InitialState
st, Tx
tx, ChainTransition
Collect)

  genCloseWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
  genCloseWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCloseWithState = do
    (ChainContext
ctx, OpenState
st, Tx
tx, ConfirmedSnapshot Tx
_) <- Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
genCloseTx Int
maxGenParties
    (ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, OpenState -> ChainState
Open OpenState
st, Tx
tx, ChainTransition
Close)

  genContestWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
  genContestWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genContestWithState = do
    (HydraContext
hctx, PointInTime
_, ClosedState
st, Tx
tx) <- Gen (HydraContext, PointInTime, ClosedState, Tx)
genContestTx
    ChainContext
ctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
hctx
    (ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, ClosedState -> ChainState
Closed ClosedState
st, Tx
tx, ChainTransition
Contest)

  genFanoutWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
  genFanoutWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genFanoutWithState = do
    Positive Int
numParties <- Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
    Positive Int
numOutputs <- Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
    (HydraContext
hctx, ClosedState
st, Tx
tx) <- Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx Int
numParties Int
numOutputs
    ChainContext
ctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
hctx
    (ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, ClosedState -> ChainState
Closed ClosedState
st, Tx
tx, ChainTransition
Fanout)

-- ** Warning zone

-- | 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 -> [SigningKey HydraKey]
ctxHydraSigningKeys :: [SigningKey HydraKey]
  , HydraContext -> NetworkId
ctxNetworkId :: NetworkId
  , HydraContext -> ContestationPeriod
ctxContestationPeriod :: ContestationPeriod
  , 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)

ctxParties :: HydraContext -> [Party]
ctxParties :: HydraContext -> [Party]
ctxParties = (SigningKey HydraKey -> Party) -> [SigningKey HydraKey] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SigningKey HydraKey -> Party
deriveParty ([SigningKey HydraKey] -> [Party])
-> (HydraContext -> [SigningKey HydraKey])
-> HydraContext
-> [Party]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys

ctxParticipants :: HydraContext -> [OnChainId]
ctxParticipants :: HydraContext -> [OnChainId]
ctxParticipants = (VerificationKey PaymentKey -> OnChainId)
-> [VerificationKey PaymentKey] -> [OnChainId]
forall a b. (a -> b) -> [a] -> [b]
map VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId ([VerificationKey PaymentKey] -> [OnChainId])
-> (HydraContext -> [VerificationKey PaymentKey])
-> HydraContext
-> [OnChainId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys

ctxHeadParameters ::
  HydraContext ->
  HeadParameters
ctxHeadParameters :: HydraContext -> HeadParameters
ctxHeadParameters ctx :: HydraContext
ctx@HydraContext{ContestationPeriod
$sel:ctxContestationPeriod:HydraContext :: HydraContext -> ContestationPeriod
ctxContestationPeriod :: ContestationPeriod
ctxContestationPeriod} =
  ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
ctxContestationPeriod (HydraContext -> [Party]
ctxParties HydraContext
ctx)

-- | Generate a `HydraContext` for a arbitrary number of parties, bounded by
-- given maximum.
genHydraContext :: Int -> Gen HydraContext
genHydraContext :: Int -> Gen HydraContext
genHydraContext Int
maxParties = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
maxParties) Gen Int -> (Int -> Gen HydraContext) -> Gen HydraContext
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Gen HydraContext
genHydraContextFor

-- | Generate a 'HydraContext' for a given number of parties.
genHydraContextFor :: Int -> Gen HydraContext
genHydraContextFor :: Int -> Gen HydraContext
genHydraContextFor Int
n = do
  [VerificationKey PaymentKey]
ctxVerificationKeys <- Int
-> Gen (VerificationKey PaymentKey)
-> Gen [VerificationKey PaymentKey]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Gen (VerificationKey PaymentKey)
genVerificationKey
  [SigningKey HydraKey]
ctxHydraSigningKeys <- Int -> Gen [SigningKey HydraKey]
forall a. Arbitrary a => Int -> Gen [a]
vector Int
n
  NetworkId
ctxNetworkId <- NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId)
-> (Word32 -> NetworkMagic) -> Word32 -> NetworkId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkId) -> Gen Word32 -> Gen NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
  ContestationPeriod
ctxContestationPeriod <- Gen ContestationPeriod
forall a. Arbitrary a => Gen a
arbitrary
  ScriptRegistry
ctxScriptRegistry <- Gen ScriptRegistry
genScriptRegistry
  HydraContext -> Gen HydraContext
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraContext -> Gen HydraContext)
-> HydraContext -> Gen HydraContext
forall a b. (a -> b) -> a -> b
$
    HydraContext
      { [VerificationKey PaymentKey]
$sel:ctxVerificationKeys:HydraContext :: [VerificationKey PaymentKey]
ctxVerificationKeys :: [VerificationKey PaymentKey]
ctxVerificationKeys
      , [SigningKey HydraKey]
$sel:ctxHydraSigningKeys:HydraContext :: [SigningKey HydraKey]
ctxHydraSigningKeys :: [SigningKey HydraKey]
ctxHydraSigningKeys
      , NetworkId
$sel:ctxNetworkId:HydraContext :: NetworkId
ctxNetworkId :: NetworkId
ctxNetworkId
      , ContestationPeriod
$sel:ctxContestationPeriod:HydraContext :: ContestationPeriod
ctxContestationPeriod :: ContestationPeriod
ctxContestationPeriod
      , ScriptRegistry
$sel:ctxScriptRegistry:HydraContext :: ScriptRegistry
ctxScriptRegistry :: ScriptRegistry
ctxScriptRegistry
      }

-- | Get all peer-specific 'ChainContext's from a 'HydraContext'. NOTE: This
-- assumes that 'HydraContext' has same length 'ctxVerificationKeys' and
-- 'ctxHydraSigningKeys'.
-- XXX: This is actually a non-monadic function.
deriveChainContexts :: HydraContext -> Gen [ChainContext]
deriveChainContexts :: HydraContext -> Gen [ChainContext]
deriveChainContexts HydraContext
ctx = do
  [ChainContext] -> Gen [ChainContext]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ChainContext] -> Gen [ChainContext])
-> [ChainContext] -> Gen [ChainContext]
forall a b. (a -> b) -> a -> b
$
    (((VerificationKey PaymentKey, Party) -> ChainContext)
 -> [(VerificationKey PaymentKey, Party)] -> [ChainContext])
-> [(VerificationKey PaymentKey, Party)]
-> ((VerificationKey PaymentKey, Party) -> ChainContext)
-> [ChainContext]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((VerificationKey PaymentKey, Party) -> ChainContext)
-> [(VerificationKey PaymentKey, Party)] -> [ChainContext]
forall a b. (a -> b) -> [a] -> [b]
map ([VerificationKey PaymentKey]
-> [Party] -> [(VerificationKey PaymentKey, Party)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VerificationKey PaymentKey]
ctxVerificationKeys [Party]
allParties') (((VerificationKey PaymentKey, Party) -> ChainContext)
 -> [ChainContext])
-> ((VerificationKey PaymentKey, Party) -> ChainContext)
-> [ChainContext]
forall a b. (a -> b) -> a -> b
$ \(VerificationKey PaymentKey
vk, Party
p) ->
      ChainContext
        { $sel:networkId:ChainContext :: NetworkId
networkId = NetworkId
ctxNetworkId
        , $sel:ownVerificationKey:ChainContext :: VerificationKey PaymentKey
ownVerificationKey = VerificationKey PaymentKey
vk
        , $sel:ownParty:ChainContext :: Party
ownParty = Party
p
        , $sel:scriptRegistry:ChainContext :: ScriptRegistry
scriptRegistry = ScriptRegistry
ctxScriptRegistry
        }
 where
  allParties' :: [Party]
allParties' = HydraContext -> [Party]
ctxParties HydraContext
ctx

  HydraContext
    { [VerificationKey PaymentKey]
$sel:ctxVerificationKeys:HydraContext :: HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys :: [VerificationKey PaymentKey]
ctxVerificationKeys
    , NetworkId
$sel:ctxNetworkId:HydraContext :: HydraContext -> NetworkId
ctxNetworkId :: NetworkId
ctxNetworkId
    , ScriptRegistry
$sel:ctxScriptRegistry:HydraContext :: HydraContext -> ScriptRegistry
ctxScriptRegistry :: ScriptRegistry
ctxScriptRegistry
    } = HydraContext
ctx

-- | Pick one of the participants and derive the peer-specific 'ChainContext'
-- from a 'HydraContext'. NOTE: This assumes that 'HydraContext' has same length
-- 'ctxVerificationKeys' and 'ctxHydraSigningKeys'.
pickChainContext :: HydraContext -> Gen ChainContext
pickChainContext :: HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx =
  HydraContext -> Gen [ChainContext]
deriveChainContexts HydraContext
ctx Gen [ChainContext]
-> ([ChainContext] -> Gen ChainContext) -> Gen ChainContext
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ChainContext] -> Gen ChainContext
forall a. [a] -> Gen a
elements

genStInitial ::
  HydraContext ->
  Gen (ChainContext, InitialState)
genStInitial :: HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx = do
  TxIn
seedInput <- Gen TxIn
genTxIn
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let txInit :: Tx
txInit = ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx TxIn
seedInput (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
  let initState :: InitialState
initState = HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit
  (ChainContext, InitialState) -> Gen (ChainContext, InitialState)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState
initState)

genInitTx ::
  HydraContext ->
  Gen Tx
genInitTx :: HydraContext -> Gen Tx
genInitTx HydraContext
ctx = do
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  TxIn
seedInput <- Gen TxIn
genTxIn
  Tx -> Gen Tx
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Gen Tx) -> Tx -> Gen Tx
forall a b. (a -> b) -> a -> b
$ ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx TxIn
seedInput (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)

genCommits ::
  HydraContext ->
  Tx ->
  Gen [Tx]
genCommits :: HydraContext -> Tx -> Gen [Tx]
genCommits =
  Gen UTxO -> HydraContext -> Tx -> Gen [Tx]
genCommits' Gen UTxO
genCommit

genCommits' ::
  Gen UTxO ->
  HydraContext ->
  Tx ->
  Gen [Tx]
genCommits' :: Gen UTxO -> HydraContext -> Tx -> Gen [Tx]
genCommits' Gen UTxO
genUTxO HydraContext
ctx Tx
txInit = do
  -- Prepare UTxO to commit. We need to scale down the quantities by number of
  -- committed UTxOs to ensure we are not as easily hitting overflows of the max
  -- bound (Word64) when collecting all the commits together later.
  [UTxO]
commitUTxOs <- [Party] -> (Party -> Gen UTxO) -> Gen [UTxO]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (HydraContext -> [Party]
ctxParties HydraContext
ctx) ((Party -> Gen UTxO) -> Gen [UTxO])
-> (Party -> Gen UTxO) -> Gen [UTxO]
forall a b. (a -> b) -> a -> b
$ Gen UTxO -> Party -> Gen UTxO
forall a b. a -> b -> a
const Gen UTxO
genUTxO
  let scaledCommitUTxOs :: [UTxO]
scaledCommitUTxOs = [UTxO] -> [UTxO]
forall {f :: * -> *} {ctx} {era}.
(Foldable f, Monoid (f (TxOut ctx era)), Functor f,
 IsMaryEraOnwards era, IsShelleyBasedEra era) =>
[f (TxOut ctx era)] -> [f (TxOut ctx era)]
scaleCommitUTxOs [UTxO]
commitUTxOs

  [ChainContext]
allChainContexts <- HydraContext -> Gen [ChainContext]
deriveChainContexts HydraContext
ctx
  [(ChainContext, UTxO)]
-> ((ChainContext, UTxO) -> Gen Tx) -> Gen [Tx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([ChainContext] -> [UTxO] -> [(ChainContext, UTxO)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ChainContext]
allChainContexts [UTxO]
scaledCommitUTxOs) (((ChainContext, UTxO) -> Gen Tx) -> Gen [Tx])
-> ((ChainContext, UTxO) -> Gen Tx) -> Gen [Tx]
forall a b. (a -> b) -> a -> b
$ \(ChainContext
cctx, UTxO
toCommit) -> do
    let stInitial :: InitialState
stInitial@InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit
    Tx -> Gen Tx
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Gen Tx) -> Tx -> Gen Tx
forall a b. (a -> b) -> a -> b
$ HasCallStack => ChainContext -> HeadId -> UTxO -> UTxO -> Tx
ChainContext -> HeadId -> UTxO -> UTxO -> Tx
unsafeCommit ChainContext
cctx HeadId
headId (InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial) UTxO
toCommit
 where
  scaleCommitUTxOs :: [f (TxOut ctx era)] -> [f (TxOut ctx era)]
scaleCommitUTxOs [f (TxOut ctx era)]
commitUTxOs =
    let numberOfUTxOs :: Int
numberOfUTxOs = f (TxOut ctx era) -> Int
forall a. f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (f (TxOut ctx era) -> Int) -> f (TxOut ctx era) -> Int
forall a b. (a -> b) -> a -> b
$ [f (TxOut ctx era)] -> f (TxOut ctx era)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [f (TxOut ctx era)]
commitUTxOs
     in (f (TxOut ctx era) -> f (TxOut ctx era))
-> [f (TxOut ctx era)] -> [f (TxOut ctx era)]
forall a b. (a -> b) -> [a] -> [b]
map ((TxOut ctx era -> TxOut ctx era)
-> f (TxOut ctx era) -> f (TxOut ctx era)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> Value) -> TxOut ctx era -> TxOut ctx era
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Int -> Value -> Value
forall {a}. Integral a => a -> Value -> Value
scaleQuantitiesDownBy Int
numberOfUTxOs))) [f (TxOut ctx era)]
commitUTxOs

  scaleQuantitiesDownBy :: a -> Value -> Value
scaleQuantitiesDownBy a
x =
    [(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Value)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map (\(AssetId
an, Quantity Integer
q) -> (AssetId
an, Integer -> Quantity
Quantity (Integer -> Quantity) -> Integer -> Quantity
forall a b. (a -> b) -> a -> b
$ Integer
q Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x)) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> (Value -> [(AssetId, Quantity)])
-> Value
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
valueToList

genCommitFor :: VerificationKey PaymentKey -> Gen UTxO
genCommitFor :: VerificationKey PaymentKey -> Gen UTxO
genCommitFor VerificationKey PaymentKey
vkey =
  [(Int, Gen UTxO)] -> Gen UTxO
forall a. [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, UTxO -> Gen UTxO
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
forall a. Monoid a => a
mempty)
    , (Int
10, VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor VerificationKey PaymentKey
vkey)
    ]

genCommit :: Gen UTxO
genCommit :: Gen UTxO
genCommit =
  [(Int, Gen UTxO)] -> Gen UTxO
forall a. [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, UTxO -> Gen UTxO
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
forall a. Monoid a => a
mempty)
    , (Int
10, Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Gen UTxO) -> Gen UTxO
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor)
    ]

genCollectComTx :: Gen (ChainContext, [UTxO], InitialState, Tx)
genCollectComTx :: Gen (ChainContext, [UTxO], InitialState, Tx)
genCollectComTx = do
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
maximumNumberOfParties
  Tx
txInit <- HydraContext -> Gen Tx
genInitTx HydraContext
ctx
  [Tx]
commits <- HydraContext -> Tx -> Gen [Tx]
genCommits HydraContext
ctx Tx
txInit
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let ([UTxO]
committedUTxO, InitialState
stInitialized) = HasCallStack =>
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
unsafeObserveInitAndCommits ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit [Tx]
commits
  let InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = InitialState
stInitialized
  let utxoToCollect :: UTxO
utxoToCollect = [UTxO] -> UTxO
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [UTxO]
committedUTxO
  let spendableUTxO :: UTxO
spendableUTxO = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitialized
  (ChainContext, [UTxO], InitialState, Tx)
-> Gen (ChainContext, [UTxO], InitialState, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, [UTxO]
committedUTxO, InitialState
stInitialized, ChainContext -> HeadId -> HeadParameters -> UTxO -> UTxO -> Tx
unsafeCollect ChainContext
cctx HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) UTxO
utxoToCollect UTxO
spendableUTxO)

genCloseTx :: Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
genCloseTx :: Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
genCloseTx Int
numParties = do
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
numParties
  (UTxO
u0, stOpen :: OpenState
stOpen@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
  ConfirmedSnapshot Tx
snapshot <- HeadId
-> SnapshotNumber
-> UTxOType Tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotNumber
-> UTxOType tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotNumber
0 UTxO
UTxOType Tx
u0 (HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys HydraContext
ctx)
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let cp :: ContestationPeriod
cp = HydraContext -> ContestationPeriod
ctxContestationPeriod HydraContext
ctx
  (SlotNo
startSlot, PointInTime
pointInTime) <- ContestationPeriod -> Gen (SlotNo, PointInTime)
genValidityBoundsFromContestationPeriod ContestationPeriod
cp
  let utxo :: UTxO
utxo = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
stOpen
  (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
-> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, OpenState
stOpen, HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
utxo HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
snapshot SlotNo
startSlot PointInTime
pointInTime, ConfirmedSnapshot Tx
snapshot)

genContestTx :: Gen (HydraContext, PointInTime, ClosedState, Tx)
genContestTx :: Gen (HydraContext, PointInTime, ClosedState, Tx)
genContestTx = do
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
maximumNumberOfParties
  (UTxO
u0, stOpen :: OpenState
stOpen@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
  ConfirmedSnapshot Tx
confirmed <- HeadId
-> SnapshotNumber
-> UTxOType Tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotNumber
-> UTxOType tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotNumber
0 UTxO
UTxOType Tx
u0 []
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let cp :: ContestationPeriod
cp = HydraContext -> ContestationPeriod
ctxContestationPeriod HydraContext
ctx
  (SlotNo
startSlot, PointInTime
closePointInTime) <- ContestationPeriod -> Gen (SlotNo, PointInTime)
genValidityBoundsFromContestationPeriod ContestationPeriod
cp
  let openUTxO :: UTxO
openUTxO = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
stOpen
  let txClose :: Tx
txClose = HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
openUTxO HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
confirmed SlotNo
startSlot PointInTime
closePointInTime
  let stClosed :: ClosedState
stClosed = (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a, b) -> b
snd ((OnChainTx Tx, ClosedState) -> ClosedState)
-> (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a -> b) -> a -> b
$ Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState))
-> Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState)
forall a b. (a -> b) -> a -> b
$ OpenState -> Tx -> Maybe (OnChainTx Tx, ClosedState)
observeClose OpenState
stOpen Tx
txClose
  let utxo :: UTxO
utxo = ClosedState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ClosedState
stClosed
  UTxO
someUtxo <- Gen UTxO
forall a. Arbitrary a => Gen a
arbitrary
  ConfirmedSnapshot Tx
contestSnapshot <- HeadId
-> SnapshotNumber
-> UTxOType Tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotNumber
-> UTxOType tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId (SnapshotNumber -> SnapshotNumber
forall a. Enum a => a -> a
succ (SnapshotNumber -> SnapshotNumber)
-> SnapshotNumber -> SnapshotNumber
forall a b. (a -> b) -> a -> b
$ Snapshot Tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number (Snapshot Tx -> SnapshotNumber) -> Snapshot Tx -> SnapshotNumber
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmed) UTxO
UTxOType Tx
someUtxo (HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys HydraContext
ctx)
  PointInTime
contestPointInTime <- UTCTime -> Gen PointInTime
genPointInTimeBefore (ClosedState -> UTCTime
getContestationDeadline ClosedState
stClosed)
  (HydraContext, PointInTime, ClosedState, Tx)
-> Gen (HydraContext, PointInTime, ClosedState, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraContext
ctx, PointInTime
closePointInTime, ClosedState
stClosed, HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
unsafeContest ChainContext
cctx UTxO
utxo HeadId
headId ContestationPeriod
cp ConfirmedSnapshot Tx
contestSnapshot PointInTime
contestPointInTime)

genFanoutTx :: Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx :: Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx Int
numParties Int
numOutputs = do
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
numParties
  UTxO
utxo <- Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
numOutputs
  (SnapshotNumber
_, UTxO
toFanout, stClosed :: ClosedState
stClosed@ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}) <- HydraContext -> UTxO -> Gen (SnapshotNumber, UTxO, ClosedState)
genStClosed HydraContext
ctx UTxO
utxo
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let deadlineSlotNo :: SlotNo
deadlineSlotNo = SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength (ClosedState -> UTCTime
getContestationDeadline ClosedState
stClosed)
      spendableUTxO :: UTxO
spendableUTxO = ClosedState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ClosedState
stClosed
  (HydraContext, ClosedState, Tx)
-> Gen (HydraContext, ClosedState, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraContext
ctx, ClosedState
stClosed, HasCallStack =>
ChainContext -> UTxO -> TxIn -> UTxO -> SlotNo -> Tx
ChainContext -> UTxO -> TxIn -> UTxO -> SlotNo -> Tx
unsafeFanout ChainContext
cctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
toFanout SlotNo
deadlineSlotNo)

getContestationDeadline :: ClosedState -> UTCTime
getContestationDeadline :: ClosedState -> UTCTime
getContestationDeadline
  ClosedState{$sel:closedThreadOutput:ClosedState :: ClosedState -> ClosedThreadOutput
closedThreadOutput = ClosedThreadOutput{POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: ClosedThreadOutput -> POSIXTime
closedContestationDeadline :: POSIXTime
closedContestationDeadline}} =
    POSIXTime -> UTCTime
posixToUTCTime POSIXTime
closedContestationDeadline

genStOpen ::
  HydraContext ->
  Gen (UTxO, OpenState)
genStOpen :: HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx = do
  Tx
txInit <- HydraContext -> Gen Tx
genInitTx HydraContext
ctx
  [Tx]
commits <- HydraContext -> Tx -> Gen [Tx]
genCommits HydraContext
ctx Tx
txInit
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let ([UTxO]
committed, InitialState
stInitial) = HasCallStack =>
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
unsafeObserveInitAndCommits ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit [Tx]
commits
  let InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = InitialState
stInitial
  let utxoToCollect :: UTxO
utxoToCollect = [UTxO] -> UTxO
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [UTxO]
committed
  let spendableUTxO :: UTxO
spendableUTxO = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial
  let txCollect :: Tx
txCollect = ChainContext -> HeadId -> HeadParameters -> UTxO -> UTxO -> Tx
unsafeCollect ChainContext
cctx HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) UTxO
utxoToCollect UTxO
spendableUTxO
  (UTxO, OpenState) -> Gen (UTxO, OpenState)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([UTxO] -> UTxO
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [UTxO]
committed, (OnChainTx Tx, OpenState) -> OpenState
forall a b. (a, b) -> b
snd ((OnChainTx Tx, OpenState) -> OpenState)
-> (Maybe (OnChainTx Tx, OpenState) -> (OnChainTx Tx, OpenState))
-> Maybe (OnChainTx Tx, OpenState)
-> OpenState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (OnChainTx Tx, OpenState) -> (OnChainTx Tx, OpenState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, OpenState) -> OpenState)
-> Maybe (OnChainTx Tx, OpenState) -> OpenState
forall a b. (a -> b) -> a -> b
$ InitialState -> Tx -> Maybe (OnChainTx Tx, OpenState)
observeCollect InitialState
stInitial Tx
txCollect)

genStClosed ::
  HydraContext ->
  UTxO ->
  Gen (SnapshotNumber, UTxO, ClosedState)
genStClosed :: HydraContext -> UTxO -> Gen (SnapshotNumber, UTxO, ClosedState)
genStClosed HydraContext
ctx UTxO
utxo = do
  (UTxO
u0, stOpen :: OpenState
stOpen@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
  ConfirmedSnapshot Tx
confirmed <- Gen (ConfirmedSnapshot Tx)
forall a. Arbitrary a => Gen a
arbitrary
  let (SnapshotNumber
sn, ConfirmedSnapshot Tx
snapshot, UTxO
toFanout) = case ConfirmedSnapshot Tx
confirmed of
        InitialSnapshot{} ->
          ( SnapshotNumber
0
          , InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId, $sel:initialUTxO:InitialSnapshot :: UTxOType Tx
initialUTxO = UTxO
UTxOType Tx
u0}
          , UTxO
u0
          )
        ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot Tx
snap, MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot Tx)
signatures} ->
          ( Snapshot Tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number Snapshot Tx
snap
          , ConfirmedSnapshot
              { $sel:snapshot:InitialSnapshot :: Snapshot Tx
snapshot = Snapshot Tx
snap{utxo = utxo}
              , MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
signatures
              }
          , UTxO
utxo
          )
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let cp :: ContestationPeriod
cp = HydraContext -> ContestationPeriod
ctxContestationPeriod HydraContext
ctx
  (SlotNo
startSlot, PointInTime
pointInTime) <- ContestationPeriod -> Gen (SlotNo, PointInTime)
genValidityBoundsFromContestationPeriod ContestationPeriod
cp
  let utxo' :: UTxO
utxo' = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
stOpen
  let txClose :: Tx
txClose = HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
utxo' HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
snapshot SlotNo
startSlot PointInTime
pointInTime
  (SnapshotNumber, UTxO, ClosedState)
-> Gen (SnapshotNumber, UTxO, ClosedState)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotNumber
sn, UTxO
toFanout, (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a, b) -> b
snd ((OnChainTx Tx, ClosedState) -> ClosedState)
-> (Maybe (OnChainTx Tx, ClosedState)
    -> (OnChainTx Tx, ClosedState))
-> Maybe (OnChainTx Tx, ClosedState)
-> ClosedState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, ClosedState) -> ClosedState)
-> Maybe (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a -> b) -> a -> b
$ OpenState -> Tx -> Maybe (OnChainTx Tx, ClosedState)
observeClose OpenState
stOpen Tx
txClose)

-- ** Danger zone

unsafeCommit ::
  HasCallStack =>
  ChainContext ->
  HeadId ->
  -- | Spendable 'UTxO'
  UTxO ->
  -- | 'UTxO' to commit. All outputs are assumed to be owned by public keys.
  UTxO ->
  Tx
unsafeCommit :: HasCallStack => ChainContext -> HeadId -> UTxO -> UTxO -> Tx
unsafeCommit ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO
utxoToCommit =
  (PostTxError Tx -> Tx)
-> (Tx -> Tx) -> Either (PostTxError Tx) Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (PostTxError Tx -> Text) -> PostTxError Tx -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostTxError Tx -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either (PostTxError Tx) Tx -> Tx)
-> Either (PostTxError Tx) Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> HeadId -> UTxO -> UTxO -> Either (PostTxError Tx) Tx
commit ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO
utxoToCommit

unsafeAbort ::
  HasCallStack =>
  ChainContext ->
  -- | Seed TxIn
  TxIn ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  -- | Committed UTxOs to reimburse.
  UTxO ->
  Tx
unsafeAbort :: HasCallStack => ChainContext -> TxIn -> UTxO -> UTxO -> Tx
unsafeAbort ChainContext
ctx TxIn
seedTxIn UTxO
spendableUTxO UTxO
committedUTxO =
  (AbortTxError -> Tx) -> (Tx -> Tx) -> Either AbortTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (AbortTxError -> Text) -> AbortTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbortTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either AbortTxError Tx -> Tx) -> Either AbortTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext -> TxIn -> UTxO -> UTxO -> Either AbortTxError Tx
abort ChainContext
ctx TxIn
seedTxIn UTxO
spendableUTxO UTxO
committedUTxO

unsafeClose ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  HeadId ->
  HeadParameters ->
  ConfirmedSnapshot Tx ->
  -- | 'Tx' validity lower bound
  SlotNo ->
  -- | 'Tx' validity upper bound
  PointInTime ->
  Tx
unsafeClose :: HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo PointInTime
pointInTime =
  (CloseTxError -> Tx) -> (Tx -> Tx) -> Either CloseTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (CloseTxError -> Text) -> CloseTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CloseTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either CloseTxError Tx -> Tx) -> Either CloseTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo PointInTime
pointInTime

unsafeCollect ::
  ChainContext ->
  HeadId ->
  HeadParameters ->
  -- | UTxO to be used to collect.
  -- Should match whatever is recorded in the commit inputs.
  UTxO ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  Tx
unsafeCollect :: ChainContext -> HeadId -> HeadParameters -> UTxO -> UTxO -> Tx
unsafeCollect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
utxoToCollect UTxO
spendableUTxO =
  (CollectTxError -> Tx)
-> (Tx -> Tx) -> Either CollectTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (CollectTxError -> Text) -> CollectTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either CollectTxError Tx -> Tx) -> Either CollectTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> HeadId
-> HeadParameters
-> UTxO
-> UTxO
-> Either CollectTxError Tx
collect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
utxoToCollect UTxO
spendableUTxO

unsafeContest ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  HeadId ->
  ContestationPeriod ->
  ConfirmedSnapshot Tx ->
  PointInTime ->
  Tx
unsafeContest :: HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
unsafeContest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot PointInTime
pointInTime =
  (ContestTxError -> Tx)
-> (Tx -> Tx) -> Either ContestTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (ContestTxError -> Text) -> ContestTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContestTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either ContestTxError Tx -> Tx) -> Either ContestTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot PointInTime
pointInTime

unsafeFanout ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | Snapshot UTxO to fanout
  UTxO ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  Tx
unsafeFanout :: HasCallStack =>
ChainContext -> UTxO -> TxIn -> UTxO -> SlotNo -> Tx
unsafeFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo SlotNo
deadlineSlotNo =
  (FanoutTxError -> Tx)
-> (Tx -> Tx) -> Either FanoutTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (FanoutTxError -> Text) -> FanoutTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FanoutTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either FanoutTxError Tx -> Tx) -> Either FanoutTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO -> TxIn -> UTxO -> SlotNo -> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo SlotNo
deadlineSlotNo

unsafeObserveInit ::
  HasCallStack =>
  ChainContext ->
  [VerificationKey PaymentKey] ->
  Tx ->
  InitialState
unsafeObserveInit :: HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
cctx [VerificationKey PaymentKey]
txInit Tx
allVerificationKeys =
  case ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> Either NotAnInitReason (OnChainTx Tx, InitialState)
observeInit ChainContext
cctx [VerificationKey PaymentKey]
txInit Tx
allVerificationKeys of
    Left NotAnInitReason
err -> Text -> InitialState
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> InitialState) -> Text -> InitialState
forall a b. (a -> b) -> a -> b
$ Text
"Did not observe an init tx: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NotAnInitReason -> Text
forall b a. (Show a, IsString b) => a -> b
show NotAnInitReason
err
    Right (OnChainTx Tx, InitialState)
st -> (OnChainTx Tx, InitialState) -> InitialState
forall a b. (a, b) -> b
snd (OnChainTx Tx, InitialState)
st

-- REVIEW: Maybe it would be more convenient if 'unsafeObserveInitAndCommits'
-- returns just 'UTXO' instead of [UTxO]
unsafeObserveInitAndCommits ::
  HasCallStack =>
  ChainContext ->
  [VerificationKey PaymentKey] ->
  Tx ->
  [Tx] ->
  ([UTxO], InitialState)
unsafeObserveInitAndCommits :: HasCallStack =>
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
unsafeObserveInitAndCommits ChainContext
ctx [VerificationKey PaymentKey]
allVerificationKeys Tx
txInit [Tx]
commits =
  ([UTxO]
utxo, InitialState
stInitial')
 where
  stInitial :: InitialState
stInitial = HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
ctx [VerificationKey PaymentKey]
allVerificationKeys Tx
txInit

  ([UTxO]
utxo, InitialState
stInitial') = (State InitialState [UTxO]
 -> InitialState -> ([UTxO], InitialState))
-> InitialState
-> State InitialState [UTxO]
-> ([UTxO], InitialState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State InitialState [UTxO] -> InitialState -> ([UTxO], InitialState)
forall s a. State s a -> s -> (a, s)
runState InitialState
stInitial (State InitialState [UTxO] -> ([UTxO], InitialState))
-> State InitialState [UTxO] -> ([UTxO], InitialState)
forall a b. (a -> b) -> a -> b
$ do
    [Tx]
-> (Tx -> StateT InitialState Identity UTxO)
-> State InitialState [UTxO]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Tx]
commits ((Tx -> StateT InitialState Identity UTxO)
 -> State InitialState [UTxO])
-> (Tx -> StateT InitialState Identity UTxO)
-> State InitialState [UTxO]
forall a b. (a -> b) -> a -> b
$ \Tx
txCommit -> do
      InitialState
st <- StateT InitialState Identity InitialState
forall s (m :: * -> *). MonadState s m => m s
get
      let (OnChainTx Tx
event, InitialState
st') = Maybe (OnChainTx Tx, InitialState) -> (OnChainTx Tx, InitialState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, InitialState)
 -> (OnChainTx Tx, InitialState))
-> Maybe (OnChainTx Tx, InitialState)
-> (OnChainTx Tx, InitialState)
forall a b. (a -> b) -> a -> b
$ ChainContext
-> InitialState -> Tx -> Maybe (OnChainTx Tx, InitialState)
observeCommit ChainContext
ctx InitialState
st Tx
txCommit
      InitialState -> StateT InitialState Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put InitialState
st'
      UTxO -> StateT InitialState Identity UTxO
forall a. a -> StateT InitialState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> StateT InitialState Identity UTxO)
-> UTxO -> StateT InitialState Identity UTxO
forall a b. (a -> b) -> a -> b
$ case OnChainTx Tx
event of
        OnCommitTx{UTxOType Tx
$sel:committed:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
committed :: UTxOType Tx
committed} -> UTxO
UTxOType Tx
committed
        OnChainTx Tx
_ -> UTxO
forall a. Monoid a => a
mempty