{-# 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.Fixed (Milli)
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import GHC.IsList qualified as IsList
import Hydra.Cardano.Api (
  AssetId (..),
  AssetName (AssetName),
  ChainPoint (..),
  CtxUTxO,
  Key (SigningKey, VerificationKey, verificationKeyHash),
  NetworkId (Mainnet, Testnet),
  NetworkMagic (NetworkMagic),
  PaymentKey,
  PlutusScriptV3,
  PolicyId,
  Quantity (..),
  SerialiseAsRawBytes (serialiseToRawBytes),
  SlotNo (SlotNo),
  ToTxContext (toTxContext),
  Tx,
  TxId,
  TxIn,
  TxOut,
  UTxO,
  UTxO' (UTxO),
  chainPointToSlotNo,
  fromPlutusScript,
  fromScriptData,
  genTxIn,
  getTxBody,
  getTxId,
  isScriptTxOut,
  modifyTxOutValue,
  negateValue,
  networkIdToNetwork,
  selectAsset,
  selectLovelace,
  toTxContext,
  txIns',
  txOutScriptData,
  txOutValue,
  txSpendingUTxO,
  pattern ByronAddressInEra,
  pattern ShelleyAddressInEra,
  pattern TxIn,
  pattern TxOut,
 )
import Hydra.Chain (
  OnChainTx (..),
  PostTxError (..),
  maxMainnetLovelace,
  maximumNumberOfParties,
 )
import Hydra.Chain.ChainState (ChainSlot (ChainSlot), IsChainState (..))
import Hydra.Chain.Direct.Tx (
  CloseObservation (..),
  CollectComObservation (..),
  CommitObservation (..),
  InitObservation (..),
  InitialThreadOutput (..),
  NotAnInitReason,
  UTxOHash,
  headIdToPolicyId,
  observeCloseTx,
  observeCollectComTx,
  observeCommitTx,
  observeInitTx,
  txInToHeadSeed,
 )
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Ledger.Cardano.Evaluate (genPointInTimeBefore, genValidityBoundsFromContestationPeriod, slotLength, systemStart)
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime)
import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
import Hydra.Plutus.Extras (posixToUTCTime)
import Hydra.Tx (
  CommitBlueprintTx (..),
  ConfirmedSnapshot (..),
  HeadId (..),
  HeadParameters (..),
  Party,
  ScriptRegistry (..),
  Snapshot (..),
  SnapshotNumber,
  SnapshotVersion,
  deriveParty,
  getSnapshot,
  partyToChain,
  registryUTxO,
  utxoFromTx,
 )
import Hydra.Tx.Abort (AbortTxError (..), abortTx)
import Hydra.Tx.Close (OpenThreadOutput (..), closeTx)
import Hydra.Tx.CollectCom (collectComTx)
import Hydra.Tx.Commit (commitTx)
import Hydra.Tx.Contest (ClosedThreadOutput (..), PointInTime, contestTx)
import Hydra.Tx.ContestationPeriod (ContestationPeriod, toChain)
import Hydra.Tx.ContestationPeriod qualified as ContestationPeriod
import Hydra.Tx.Crypto (HydraKey)
import Hydra.Tx.Decrement (decrementTx)
import Hydra.Tx.Deposit (DepositObservation (..), depositTx, observeDepositTx, observeDepositTxOut)
import Hydra.Tx.Fanout (fanoutTx)
import Hydra.Tx.Increment (incrementTx)
import Hydra.Tx.Init (initTx)
import Hydra.Tx.OnChainId (OnChainId)
import Hydra.Tx.Recover (recoverTx)
import Hydra.Tx.Snapshot (genConfirmedSnapshot)
import Hydra.Tx.Utils (splitUTxO, verificationKeyToOnChainId)
import Test.Hydra.Tx.Fixture (testNetworkId)
import Test.Hydra.Tx.Gen (
  genOneUTxOFor,
  genScriptRegistry,
  genTxOut,
  genUTxO1,
  genUTxOAdaOnlyOfSize,
  genVerificationKey,
 )
import Test.QuickCheck (choose, frequency, oneof, suchThat, 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
  | Increment
  | Decrement
  | 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 <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
maximumNumberOfParties) Gen Int -> (Int -> Gen [Party]) -> Gen [Party]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n -> Int -> Gen Party -> Gen [Party]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Gen Party
forall a. Arbitrary a => Gen a
arbitrary
    Party
ownParty <- [Party] -> Gen Party
forall a. HasCallStack => [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)]
initialInitials :: [(TxIn, TxOut CtxUTxO)]
  , InitialState -> [(TxIn, TxOut CtxUTxO)]
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) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO) -> UTxO)
-> Map TxIn (TxOut CtxUTxO) -> UTxO
forall a b. (a -> b) -> a -> b
$
      [(TxIn, TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO))
-> [(TxIn, TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$
        (TxIn, TxOut CtxUTxO)
initialThreadUTxO (TxIn, TxOut CtxUTxO)
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. a -> [a] -> [a]
: [(TxIn, TxOut CtxUTxO)]
initialCommits [(TxIn, TxOut CtxUTxO)]
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. Semigroup a => a -> a -> a
<> [(TxIn, TxOut CtxUTxO)]
initialInitials
   where
    InitialState
      { $sel:initialThreadOutput:InitialState :: InitialState -> InitialThreadOutput
initialThreadOutput = InitialThreadOutput{(TxIn, TxOut CtxUTxO)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
$sel:initialThreadUTxO:InitialThreadOutput :: InitialThreadOutput -> (TxIn, TxOut CtxUTxO)
initialThreadUTxO}
      , [(TxIn, TxOut CtxUTxO)]
$sel:initialInitials:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO)]
initialInitials :: [(TxIn, TxOut CtxUTxO)]
initialInitials
      , [(TxIn, TxOut CtxUTxO)]
$sel:initialCommits:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO)]
initialCommits :: [(TxIn, TxOut CtxUTxO)]
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) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO)
openThreadUTxO
   where
    OpenState
      { $sel:openThreadOutput:OpenState :: OpenState -> OpenThreadOutput
openThreadOutput = OpenThreadOutput{(TxIn, TxOut CtxUTxO)
openThreadUTxO :: (TxIn, TxOut CtxUTxO)
$sel:openThreadUTxO:OpenThreadOutput :: OpenThreadOutput -> (TxIn, TxOut CtxUTxO)
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, UTxO
_, Tx
_) <- Int -> Int -> Gen (HydraContext, ClosedState, UTxO, 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) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO)
closedThreadUTxO
   where
    ClosedState
      { $sel:closedThreadOutput:ClosedState :: ClosedState -> ClosedThreadOutput
closedThreadOutput = ClosedThreadOutput{(TxIn, TxOut CtxUTxO)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO)
$sel:closedThreadUTxO:ClosedThreadOutput :: ClosedThreadOutput -> (TxIn, TxOut CtxUTxO)
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
lookupUTxO =
  let blueprintTx :: Tx
blueprintTx = UTxO -> Tx
txSpendingUTxO UTxO
lookupUTxO
   in ChainContext
-> HeadId
-> UTxO
-> CommitBlueprintTx Tx
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO CommitBlueprintTx{UTxOType Tx
UTxO
lookupUTxO :: UTxO
$sel:lookupUTxO:CommitBlueprintTx :: UTxOType Tx
lookupUTxO, Tx
blueprintTx :: Tx
$sel:blueprintTx:CommitBlueprintTx :: Tx
blueprintTx}

-- | Construct a commit transaction based on known, spendable UTxO and some
-- user UTxO inputs 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 ->
  CommitBlueprintTx Tx ->
  Either (PostTxError Tx) Tx
commit' :: ChainContext
-> HeadId
-> UTxO
-> CommitBlueprintTx Tx
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO CommitBlueprintTx Tx
commitBlueprintTx = 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
o) <- PolicyId -> Maybe (TxIn, TxOut CtxUTxO)
ownInitial PolicyId
pid Maybe (TxIn, TxOut CtxUTxO)
-> PostTxError Tx -> Either (PostTxError Tx) (TxIn, TxOut CtxUTxO)
forall a e. Maybe a -> e -> Either e a
?> CannotFindOwnInitial{$sel:knownUTxO:NoSeedInput :: UTxOType Tx
knownUTxO = UTxOType Tx
UTxO
spendableUTxO}
  UTxO -> Either (PostTxError Tx) ()
rejectByronAddress UTxOType Tx
UTxO
lookupUTxO
  NetworkId -> UTxO -> Either (PostTxError Tx) ()
rejectMoreThanMainnetLimit NetworkId
networkId UTxOType Tx
UTxO
lookupUTxO
  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
-> CommitBlueprintTx Tx
-> (TxIn, TxOut CtxUTxO, Hash PaymentKey)
-> Tx
commitTx NetworkId
networkId ScriptRegistry
scriptRegistry HeadId
headId Party
ownParty CommitBlueprintTx Tx
commitBlueprintTx (TxIn
i, TxOut CtxUTxO
o, Hash PaymentKey
vkh)
 where
  CommitBlueprintTx{UTxOType Tx
$sel:lookupUTxO:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> UTxOType tx
lookupUTxO :: UTxOType Tx
lookupUTxO} = CommitBlueprintTx Tx
commitBlueprintTx

  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)
ownInitial PolicyId
pid =
    (TxOut CtxUTxO -> Bool) -> UTxO -> Maybe (TxIn, TxOut CtxUTxO)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PolicyId -> Value -> Bool
hasMatchingPT PolicyId
pid (Value -> Bool)
-> (TxOut CtxUTxO -> Value) -> TxOut CtxUTxO -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> 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 -> 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 -> Either (PostTxError Tx) ())
 -> Either (PostTxError Tx) ())
-> (TxOut CtxUTxO -> 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 ()

-- 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
&& Lovelace
lovelaceAmt Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
> Lovelace
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
$
      Lovelace -> Lovelace -> PostTxError Tx
forall tx. Lovelace -> Lovelace -> PostTxError tx
CommittedTooMuchADAForMainnet Lovelace
lovelaceAmt Lovelace
maxMainnetLovelace
 where
  lovelaceAmt :: Lovelace
lovelaceAmt = (TxOut CtxUTxO -> Lovelace) -> UTxO -> Lovelace
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 -> Lovelace
selectLovelace (Value -> Lovelace)
-> (TxOut CtxUTxO -> Value) -> TxOut CtxUTxO -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> 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)
headUTxO <-
    Either AbortTxError (TxIn, TxOut CtxUTxO)
-> ((TxIn, TxOut CtxUTxO)
    -> Either AbortTxError (TxIn, TxOut CtxUTxO))
-> Maybe (TxIn, TxOut CtxUTxO)
-> Either AbortTxError (TxIn, TxOut CtxUTxO)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AbortTxError -> Either AbortTxError (TxIn, TxOut CtxUTxO)
forall a b. a -> Either a b
Left AbortTxError
CannotFindHeadOutputToAbort) (TxIn, TxOut CtxUTxO) -> Either AbortTxError (TxIn, TxOut CtxUTxO)
forall a. a -> Either AbortTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TxIn, TxOut CtxUTxO)
 -> Either AbortTxError (TxIn, TxOut CtxUTxO))
-> Maybe (TxIn, TxOut CtxUTxO)
-> Either AbortTxError (TxIn, TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$
      (TxOut CtxUTxO -> Bool) -> UTxO -> Maybe (TxIn, TxOut CtxUTxO)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
headScript) UTxO
utxoOfThisHead'

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

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

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

  commitScript :: PlutusScript PlutusScriptV3
commitScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
commitValidatorScript

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

  initialScript :: PlutusScript PlutusScriptV3
initialScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
initialValidatorScript

  headTokenScript :: PlutusScript PlutusScriptV3
headTokenScript = TxIn -> PlutusScript PlutusScriptV3
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)
headUTxO <- (TxOut CtxUTxO -> Bool) -> UTxO -> Maybe (TxIn, TxOut CtxUTxO)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
headScript) UTxO
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO)
-> CollectTxError -> Either CollectTxError (TxIn, TxOut CtxUTxO)
forall a e. Maybe a -> e -> Either e a
?> CollectTxError
CannotFindHeadOutputToCollect
  let commits :: Map TxIn (TxOut CtxUTxO)
commits = UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (UTxO -> Map TxIn (TxOut CtxUTxO))
-> UTxO -> Map TxIn (TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
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)
-> Map TxIn (TxOut CtxUTxO)
-> UTxO
-> Tx
collectComTx NetworkId
networkId ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey HeadId
headId HeadParameters
headParameters (TxIn, TxOut CtxUTxO)
headUTxO Map TxIn (TxOut CtxUTxO)
commits UTxO
utxoToCollect
 where
  headScript :: PlutusScript PlutusScriptV3
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
Head.validatorScript

  commitScript :: PlutusScript PlutusScriptV3
commitScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
commitValidatorScript

  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

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

-- | Construct a increment transaction spending the head and deposit outputs in given 'UTxO',
-- and producing single head output for pending 'utxoToCommit' of given 'Snapshot'.
increment ::
  ChainContext ->
  -- | Spendable UTxO containing head and deposit outputs
  UTxO ->
  HeadId ->
  HeadParameters ->
  -- | Snapshot to increment with.
  ConfirmedSnapshot Tx ->
  -- | Deposited TxId
  TxId ->
  SlotNo ->
  Either IncrementTxError Tx
increment :: ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> TxId
-> SlotNo
-> Either IncrementTxError Tx
increment ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
incrementingSnapshot TxId
depositTxId SlotNo
upperValiditySlot = do
  PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId
-> IncrementTxError -> Either IncrementTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInIncrement{HeadId
$sel:headId:InvalidHeadIdInIncrement :: HeadId
headId :: HeadId
headId}
  let utxoOfThisHead' :: UTxO
utxoOfThisHead' = PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO
  (TxIn, TxOut CtxUTxO)
headUTxO <- (TxOut CtxUTxO -> Bool) -> UTxO -> Maybe (TxIn, TxOut CtxUTxO)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
headScript) UTxO
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO)
forall a e. Maybe a -> e -> Either e a
?> IncrementTxError
CannotFindHeadOutputInIncrement
  (TxIn
depositedIn, TxOut CtxUTxO
depositedOut) <-
    ((TxIn, TxOut CtxUTxO) -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO)
forall out. ((TxIn, out) -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.findBy
      ( \(TxIn TxId
txid TxIx
_, TxOut CtxUTxO
txout) ->
          PlutusScript PlutusScriptV3 -> TxOut CtxUTxO -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
depositScript TxOut CtxUTxO
txout Bool -> Bool -> Bool
&& TxId
txid TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId
depositTxId
      )
      UTxO
spendableUTxO
      Maybe (TxIn, TxOut CtxUTxO)
-> IncrementTxError
-> Either IncrementTxError (TxIn, TxOut CtxUTxO)
forall a e. Maybe a -> e -> Either e a
?> CannotFindDepositOutputInIncrement{TxId
$sel:depositTxId:InvalidHeadIdInIncrement :: TxId
depositTxId :: TxId
depositTxId}
  case Maybe (UTxOType Tx)
utxoToCommit of
    Maybe (UTxOType Tx)
Nothing ->
      IncrementTxError -> Either IncrementTxError Tx
forall a b. a -> Either a b
Left IncrementTxError
SnapshotMissingIncrementUTxO
    Just UTxOType Tx
deposit
      | UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UTxOType Tx
UTxO
deposit ->
          IncrementTxError -> Either IncrementTxError Tx
forall a b. a -> Either a b
Left IncrementTxError
SnapshotIncrementUTxOIsNull
      | Bool
otherwise -> Tx -> Either IncrementTxError Tx
forall a b. b -> Either a b
Right (Tx -> Either IncrementTxError Tx)
-> Tx -> Either IncrementTxError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> HeadParameters
-> (TxIn, TxOut CtxUTxO)
-> Snapshot Tx
-> UTxO
-> SlotNo
-> Tx
incrementTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey HeadId
headId HeadParameters
headParameters (TxIn, TxOut CtxUTxO)
headUTxO Snapshot Tx
sn ((TxIn, TxOut CtxUTxO) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
depositedIn, TxOut CtxUTxO
depositedOut)) SlotNo
upperValiditySlot
 where
  headScript :: PlutusScript PlutusScriptV3
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
Head.validatorScript
  depositScript :: PlutusScript PlutusScriptV3
depositScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
Deposit.validatorScript

  Snapshot{Maybe (UTxOType Tx)
utxoToCommit :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType Tx)
utxoToCommit} = Snapshot Tx
sn

  sn :: Snapshot Tx
sn =
    case ConfirmedSnapshot Tx
incrementingSnapshot of
      ConfirmedSnapshot{Snapshot Tx
snapshot :: Snapshot Tx
$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot} -> Snapshot Tx
snapshot
      ConfirmedSnapshot Tx
_ -> ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
incrementingSnapshot

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

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

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

  decommitValue :: Value
decommitValue = (TxOut CtxUTxO -> Value) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue (UTxO -> Value) -> UTxO -> Value
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO -> UTxO
forall a. a -> Maybe a -> a
fromMaybe UTxO
forall a. Monoid a => a
mempty (Maybe UTxO -> UTxO) -> Maybe UTxO -> UTxO
forall a b. (a -> b) -> a -> b
$ Snapshot Tx -> Maybe (UTxOType Tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit Snapshot Tx
sn

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

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

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

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

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

-- | Construct a recover transaction spending the deposit output
-- and producing outputs the user initially deposited.
recover ::
  ChainContext ->
  HeadId ->
  -- | Deposit TxId
  TxId ->
  -- | Spendable UTxO
  UTxO ->
  SlotNo ->
  Either RecoverTxError Tx
recover :: ChainContext
-> HeadId -> TxId -> UTxO -> SlotNo -> Either RecoverTxError Tx
recover ChainContext
ctx HeadId
headId TxId
depositedTxId UTxO
spendableUTxO SlotNo
lowerValiditySlot = do
  (TxIn
_, TxOut CtxUTxO
depositedOut) <-
    ((TxIn, TxOut CtxUTxO) -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO)
forall out. ((TxIn, out) -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.findBy
      ( \(TxIn TxId
txid TxIx
_, TxOut CtxUTxO
txout) ->
          PlutusScript PlutusScriptV3 -> TxOut CtxUTxO -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
depositScript TxOut CtxUTxO
txout Bool -> Bool -> Bool
&& TxId
txid TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId
depositedTxId
      )
      UTxO
spendableUTxO
      Maybe (TxIn, TxOut CtxUTxO)
-> RecoverTxError -> Either RecoverTxError (TxIn, TxOut CtxUTxO)
forall a e. Maybe a -> e -> Either e a
?> CannotFindDepositOutputToRecover{$sel:depositTxId:InvalidHeadIdInRecover :: TxId
depositTxId = TxId
depositedTxId}
  (HeadId
headId', UTxO
deposited, POSIXTime
_deadline) <-
    Network -> TxOut CtxUTxO -> Maybe (HeadId, UTxO, POSIXTime)
observeDepositTxOut (NetworkId -> Network
networkIdToNetwork NetworkId
networkId) TxOut CtxUTxO
depositedOut
      Maybe (HeadId, UTxO, POSIXTime)
-> RecoverTxError
-> Either RecoverTxError (HeadId, UTxO, POSIXTime)
forall a e. Maybe a -> e -> Either e a
?> CannotFindDepositedOutputToRecover{$sel:depositedTxId:InvalidHeadIdInRecover :: TxId
depositedTxId = TxId
depositedTxId}
  if HeadId
headId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
/= HeadId
headId'
    then RecoverTxError -> Either RecoverTxError Tx
forall a b. a -> Either a b
Left InvalidHeadIdInRecover{HeadId
$sel:headId:InvalidHeadIdInRecover :: HeadId
headId :: HeadId
headId}
    else Tx -> Either RecoverTxError Tx
forall a b. b -> Either a b
Right (Tx -> Either RecoverTxError Tx) -> Tx -> Either RecoverTxError Tx
forall a b. (a -> b) -> a -> b
$ TxId -> UTxO -> SlotNo -> Tx
recoverTx TxId
depositedTxId UTxO
deposited SlotNo
lowerValiditySlot
 where
  depositScript :: PlutusScript PlutusScriptV3
depositScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
Deposit.validatorScript
  ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId} = ChainContext
ctx

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

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

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

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

    case State
datum of
      Head.Closed Head.ClosedDatum{[PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:ClosedDatum :: ClosedDatum -> [PubKeyHash]
contesters, [Party]
parties :: [Party]
$sel:parties:ClosedDatum :: ClosedDatum -> [Party]
parties, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:ClosedDatum :: ClosedDatum -> POSIXTime
contestationDeadline} -> do
        let closedThreadUTxO :: (TxIn, TxOut CtxUTxO)
closedThreadUTxO = (TxIn, TxOut CtxUTxO)
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)
$sel:closedThreadUTxO:ClosedThreadOutput :: (TxIn, TxOut CtxUTxO)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO)
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
contestingSnapshot of
      ConfirmedSnapshot{Snapshot Tx
$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot :: Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot Tx)
signatures} -> (Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
signatures)
      -- XXX: This way of retrofitting an 'InitialSnapshot' into a Snapshot +
      -- Signatures indicates we might want to simplify 'ConfirmedSnapshot' into
      -- a product directly.
      ConfirmedSnapshot Tx
_ -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
contestingSnapshot, MultiSignature (Snapshot Tx)
forall a. Monoid a => a
mempty)

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

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

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

-- | Construct a fanout transaction based on the 'ClosedState' and off-chain
-- agreed 'UTxO' set to fan out.
fanout ::
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | Snapshot UTxO to fanout
  UTxO ->
  -- | Snapshot UTxO to decommit to fanout
  Maybe UTxO ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  Either FanoutTxError Tx
fanout :: ChainContext
-> UTxO
-> TxIn
-> UTxO
-> Maybe UTxO
-> SlotNo
-> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo Maybe UTxO
utxoToDecommit SlotNo
deadlineSlotNo = do
  (TxIn, TxOut CtxUTxO)
headUTxO <-
    (TxOut CtxUTxO -> Bool) -> UTxO -> Maybe (TxIn, TxOut CtxUTxO)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV3 -> TxOut CtxUTxO -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
headScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
spendableUTxO)
      Maybe (TxIn, TxOut CtxUTxO)
-> FanoutTxError -> Either FanoutTxError (TxIn, TxOut CtxUTxO)
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
CannotFindHeadOutputToFanout

  (TxIn, TxOut CtxUTxO)
closedThreadUTxO <- (TxIn, TxOut CtxUTxO) -> Either FanoutTxError (TxIn, TxOut CtxUTxO)
forall {a} {era}.
(a, TxOut CtxUTxO era)
-> Either FanoutTxError (a, TxOut CtxUTxO era)
checkHeadDatum (TxIn, TxOut CtxUTxO)
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
-> Maybe UTxO
-> (TxIn, TxOut CtxUTxO)
-> SlotNo
-> PlutusScript PlutusScriptV3
-> Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO
utxo Maybe UTxO
utxoToDecommit (TxIn, TxOut CtxUTxO)
closedThreadUTxO SlotNo
deadlineSlotNo PlutusScript PlutusScriptV3
headTokenScript
 where
  headTokenScript :: PlutusScript PlutusScriptV3
headTokenScript = TxIn -> PlutusScript PlutusScriptV3
mkHeadTokenScript TxIn
seedTxIn

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

  headScript :: PlutusScript PlutusScriptV3
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 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 -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter TxOut CtxUTxO -> Bool
hasHeadToken
 where
  hasHeadToken :: TxOut CtxUTxO -> Bool
hasHeadToken =
    Maybe (AssetId, Quantity) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (AssetId, Quantity) -> Bool)
-> (TxOut CtxUTxO -> Maybe (AssetId, Quantity))
-> TxOut CtxUTxO
-> 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 -> [(AssetId, Quantity)])
-> TxOut CtxUTxO
-> Maybe (AssetId, Quantity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
Value -> [Item Value]
forall l. IsList l => l -> [Item l]
IsList.toList (Value -> [(AssetId, Quantity)])
-> (TxOut CtxUTxO -> Value)
-> TxOut CtxUTxO
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO -> 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)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
$sel:initialThreadUTxO:InitObservation :: InitObservation -> (TxIn, TxOut CtxUTxO)
initialThreadUTxO, [Party]
$sel:parties:InitObservation :: InitObservation -> [Party]
parties :: [Party]
parties, ContestationPeriod
$sel:contestationPeriod:InitObservation :: InitObservation -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [(TxIn, TxOut CtxUTxO)]
initials :: [(TxIn, TxOut CtxUTxO)]
$sel:initials:InitObservation :: InitObservation -> [(TxIn, TxOut CtxUTxO)]
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)
$sel:initialThreadUTxO:InitialThreadOutput :: (TxIn, TxOut CtxUTxO)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
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)]
initialInitials = [(TxIn, TxOut CtxUTxO)]
initials
      , $sel:initialCommits:InitialState :: [(TxIn, TxOut CtxUTxO)]
initialCommits = [(TxIn, TxOut CtxUTxO)]
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)
commitOutput :: (TxIn, TxOut CtxUTxO)
$sel:commitOutput:CommitObservation :: CommitObservation -> (TxIn, TxOut CtxUTxO)
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, UTxOType Tx
UTxO
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)]
$sel:initialCommits:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO)]
initialCommits :: [(TxIn, TxOut CtxUTxO)]
initialCommits
    , [(TxIn, TxOut CtxUTxO)]
$sel:initialInitials:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO)]
initialInitials :: [(TxIn, TxOut CtxUTxO)]
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. HasCallStack => [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, UTxO, Tx, ChainTransition)
genChainStateWithTx :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genChainStateWithTx =
  [Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)]
-> Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genInitWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genAbortWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genCommitWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genIncrementWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genDecrementWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genCollectWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genCloseWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genContestWithState
    , Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genFanoutWithState
    ]
 where
  genInitWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
  genInitWithState :: Gen (ChainContext, ChainState, UTxO, 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, UTxO, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, ChainState
Idle, UTxO
forall a. Monoid a => a
mempty, Tx
tx, ChainTransition
Init)

  genAbortWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
  genAbortWithState :: Gen (ChainContext, ChainState, UTxO, 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, UTxO, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState -> ChainState
Initial InitialState
stInitial, UTxO
forall a. Monoid a => a
mempty, Tx
tx, ChainTransition
Abort)

  genCommitWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
  genCommitWithState :: Gen (ChainContext, ChainState, UTxO, 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, UTxO, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState -> ChainState
Initial InitialState
stInitial, UTxO
forall a. Monoid a => a
mempty, Tx
tx, ChainTransition
Commit)

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

  genIncrementWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
  genIncrementWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genIncrementWithState = do
    (ChainContext
ctx, [TxOut CtxUTxO]
_, OpenState
st, UTxO
utxo, Tx
tx) <- Int -> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
genIncrementTx Int
maxGenParties
    (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, OpenState -> ChainState
Open OpenState
st, UTxO
utxo, Tx
tx, ChainTransition
Increment)

  genDecrementWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
  genDecrementWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
genDecrementWithState = do
    (ChainContext
ctx, [TxOut CtxUTxO]
_, OpenState
st, UTxO
utxo, Tx
tx) <- Int -> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
genDecrementTx Int
maxGenParties
    (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, OpenState -> ChainState
Open OpenState
st, UTxO
utxo, Tx
tx, ChainTransition
Decrement)

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

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

  genFanoutWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
  genFanoutWithState :: Gen (ChainContext, ChainState, UTxO, 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, UTxO
utxo, Tx
tx) <- Int -> Int -> Gen (HydraContext, ClosedState, UTxO, Tx)
genFanoutTx Int
numParties Int
numOutputs
    ChainContext
ctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
hctx
    (ChainContext, ChainState, UTxO, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, ClosedState -> ChainState
Closed ClosedState
st, UTxO
utxo, 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. HasCallStack => [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,
 IsMaryBasedEra 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.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Int -> Value -> Value
forall {c} {a} {a} {a}.
(Item c ~ (a, Quantity), Item a ~ (a, Quantity), Integral a,
 IsList c, IsList a) =>
a -> a -> c
scaleQuantitiesDownBy Int
numberOfUTxOs))) [f (TxOut ctx era)]
commitUTxOs

  scaleQuantitiesDownBy :: a -> a -> c
scaleQuantitiesDownBy a
x =
    -- XXX: Foldable Value instance would be nice here
    [(a, Quantity)] -> c
[Item c] -> c
forall l. IsList l => [Item l] -> l
IsList.fromList
      ([(a, Quantity)] -> c) -> (a -> [(a, Quantity)]) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Quantity) -> (a, Quantity))
-> [(a, Quantity)] -> [(a, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
an, Quantity Integer
q) -> (a
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))
      ([(a, Quantity)] -> [(a, Quantity)])
-> (a -> [(a, Quantity)]) -> a -> [(a, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [(a, Quantity)]
a -> [Item a]
forall l. IsList l => l -> [Item l]
IsList.toList

genCommitFor :: VerificationKey PaymentKey -> Gen UTxO
genCommitFor :: VerificationKey PaymentKey -> Gen UTxO
genCommitFor VerificationKey PaymentKey
vkey =
  [(Int, Gen UTxO)] -> Gen UTxO
forall a. HasCallStack => [(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. HasCallStack => [(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, UTxO, Tx)
genCollectComTx :: Gen (ChainContext, [UTxO], InitialState, UTxO, 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, UTxO, Tx)
-> Gen (ChainContext, [UTxO], InitialState, UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, [UTxO]
committedUTxO, InitialState
stInitialized, UTxO
forall a. Monoid a => a
mempty, ChainContext -> HeadId -> HeadParameters -> UTxO -> UTxO -> Tx
unsafeCollect ChainContext
cctx HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) UTxO
utxoToCollect UTxO
spendableUTxO)

genDepositTx :: Gen (UTxO, Tx)
genDepositTx :: Gen (UTxO, Tx)
genDepositTx = do
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
1
  UTxO
utxo <- Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
1 Gen UTxO -> (UTxO -> Bool) -> Gen UTxO
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool) -> (UTxO -> Bool) -> UTxO -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
  (UTxO
_, OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
  UTCTime
deadline <- POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> (Milli -> POSIXTime) -> Milli -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Milli -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Milli -> UTCTime) -> Gen Milli -> Gen UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen Milli
forall a. Arbitrary a => Gen a
arbitrary :: Gen Milli)
  let tx :: Tx
tx = NetworkId -> HeadId -> CommitBlueprintTx Tx -> UTCTime -> Tx
depositTx (HydraContext -> NetworkId
ctxNetworkId HydraContext
ctx) HeadId
headId CommitBlueprintTx{$sel:blueprintTx:CommitBlueprintTx :: Tx
blueprintTx = UTxO -> Tx
txSpendingUTxO UTxO
utxo, $sel:lookupUTxO:CommitBlueprintTx :: UTxOType Tx
lookupUTxO = UTxOType Tx
UTxO
utxo} UTCTime
deadline
  (UTxO, Tx) -> Gen (UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO
utxo, Tx
tx)

genRecoverTx ::
  Gen (UTxO, Tx)
genRecoverTx :: Gen (UTxO, Tx)
genRecoverTx = do
  (UTxO
_depositedUTxO, Tx
txDeposit) <- Gen (UTxO, Tx)
genDepositTx
  let DepositObservation{UTxO
deposited :: UTxO
$sel:deposited:DepositObservation :: DepositObservation -> UTxO
deposited} =
        Maybe DepositObservation -> DepositObservation
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DepositObservation -> DepositObservation)
-> Maybe DepositObservation -> DepositObservation
forall a b. (a -> b) -> a -> b
$ NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
testNetworkId Tx
txDeposit
  -- TODO: generate multiple various slots after deadline
  let tx :: Tx
tx = TxId -> UTxO -> SlotNo -> Tx
recoverTx (TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> TxBody Era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
txDeposit) UTxO
deposited SlotNo
100
  (UTxO, Tx) -> Gen (UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> UTxOType Tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx Tx
txDeposit, Tx
tx)

genIncrementTx :: Int -> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
genIncrementTx :: Int -> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
genIncrementTx Int
numParties = do
  (UTxO
_utxo, Tx
txDeposit) <- Gen (UTxO, Tx)
genDepositTx
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
numParties
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let DepositObservation{UTxO
$sel:deposited:DepositObservation :: DepositObservation -> UTxO
deposited :: UTxO
deposited, TxId
depositTxId :: TxId
$sel:depositTxId:DepositObservation :: DepositObservation -> TxId
depositTxId} = Maybe DepositObservation -> DepositObservation
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DepositObservation -> DepositObservation)
-> Maybe DepositObservation -> DepositObservation
forall a b. (a -> b) -> a -> b
$ NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx (HydraContext -> NetworkId
ctxNetworkId HydraContext
ctx) Tx
txDeposit
  (UTxO
_, st :: OpenState
st@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
  let openUTxO :: UTxO
openUTxO = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
st
  let version :: SnapshotNumber
version = SnapshotNumber
1
  ConfirmedSnapshot Tx
snapshot <- HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType Tx
-> Maybe (UTxOType Tx)
-> Maybe (UTxOType Tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotVersion
2 SnapshotNumber
version UTxOType Tx
UTxO
openUTxO (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
deposited) Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing (HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys HydraContext
ctx)
  let depositUTxO :: UTxOType Tx
depositUTxO = Tx -> UTxOType Tx
forall tx. IsTx tx => tx -> UTxOType tx
utxoFromTx Tx
txDeposit
  SlotNo
slotNo <- Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary
  (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
-> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ChainContext
cctx
    , [TxOut CtxUTxO]
-> (UTxO -> [TxOut CtxUTxO]) -> Maybe UTxO -> [TxOut CtxUTxO]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TxOut CtxUTxO]
forall a. Monoid a => a
mempty UTxO -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Snapshot Tx -> Maybe (UTxOType Tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToCommit (Snapshot Tx -> Maybe (UTxOType Tx))
-> Snapshot Tx -> Maybe (UTxOType Tx)
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
snapshot)
    , OpenState
st
    , UTxOType Tx
UTxO
depositUTxO
    , HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> TxId
-> SlotNo
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> TxId
-> SlotNo
-> Tx
unsafeIncrement ChainContext
cctx (UTxO
openUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxOType Tx
UTxO
depositUTxO) HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
snapshot TxId
depositTxId SlotNo
slotNo
    )

genDecrementTx :: Int -> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
genDecrementTx :: Int -> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
genDecrementTx 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 Gen (UTxO, OpenState)
-> ((UTxO, OpenState) -> Bool) -> Gen (UTxO, OpenState)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` \(UTxO
u, OpenState
_) -> Bool -> Bool
not (UTxO -> Bool
forall a. UTxO' a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UTxO
u)
  ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
  let (UTxO
confirmedUtxo, UTxO
toDecommit) = UTxO -> (UTxO, UTxO)
splitUTxO UTxO
u0
  let version :: SnapshotVersion
version = SnapshotVersion
0
  ConfirmedSnapshot Tx
snapshot <- HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType Tx
-> Maybe (UTxOType Tx)
-> Maybe (UTxOType Tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotVersion
version SnapshotNumber
1 UTxOType Tx
UTxO
confirmedUtxo Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
toDecommit) (HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys HydraContext
ctx)
  let openUTxO :: UTxO
openUTxO = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
stOpen
  (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
-> Gen (ChainContext, [TxOut CtxUTxO], OpenState, UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( ChainContext
cctx
    , [TxOut CtxUTxO]
-> (UTxO -> [TxOut CtxUTxO]) -> Maybe UTxO -> [TxOut CtxUTxO]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TxOut CtxUTxO]
forall a. Monoid a => a
mempty UTxO -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Snapshot Tx -> Maybe (UTxOType Tx)
forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit (Snapshot Tx -> Maybe (UTxOType Tx))
-> Snapshot Tx -> Maybe (UTxOType Tx)
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
snapshot)
    , OpenState
stOpen
    , UTxO
forall a. Monoid a => a
mempty
    , HasCallStack =>
ChainContext
-> UTxO -> HeadId -> HeadParameters -> ConfirmedSnapshot Tx -> Tx
ChainContext
-> UTxO -> HeadId -> HeadParameters -> ConfirmedSnapshot Tx -> Tx
unsafeDecrement ChainContext
cctx UTxO
openUTxO HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
snapshot
    )

genCloseTx :: Int -> Gen (ChainContext, OpenState, UTxO, Tx, ConfirmedSnapshot Tx)
genCloseTx :: Int
-> Gen (ChainContext, OpenState, UTxO, 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
  let (UTxO
confirmedUtxo, UTxO
utxoToDecommit) = UTxO -> (UTxO, UTxO)
splitUTxO UTxO
u0
  let version :: SnapshotVersion
version = SnapshotVersion
0
  ConfirmedSnapshot Tx
snapshot <- HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType Tx
-> Maybe (UTxOType Tx)
-> Maybe (UTxOType Tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotVersion
version SnapshotNumber
1 UTxOType Tx
UTxO
confirmedUtxo Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToDecommit) (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, UTxO, Tx, ConfirmedSnapshot Tx)
-> Gen (ChainContext, OpenState, UTxO, Tx, ConfirmedSnapshot Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, OpenState
stOpen, UTxO
forall a. Monoid a => a
mempty, HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
utxo HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) SnapshotVersion
version ConfirmedSnapshot Tx
snapshot SlotNo
startSlot PointInTime
pointInTime, ConfirmedSnapshot Tx
snapshot)

genContestTx :: Gen (HydraContext, PointInTime, ClosedState, UTxO, Tx)
genContestTx :: Gen (HydraContext, PointInTime, ClosedState, UTxO, 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
  let (UTxO
confirmedUtXO, UTxO
utxoToDecommit) = UTxO -> (UTxO, UTxO)
splitUTxO UTxO
u0
  let version :: SnapshotVersion
version = SnapshotVersion
1
  ConfirmedSnapshot Tx
confirmed <- HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType Tx
-> Maybe (UTxOType Tx)
-> Maybe (UTxOType Tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotVersion
version SnapshotNumber
1 UTxOType Tx
UTxO
confirmedUtXO Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToDecommit) []
  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
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
openUTxO HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) SnapshotVersion
version 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 (TxOut CtxUTxO) -> Gen UTxO
genUTxO1 Gen (TxOut CtxUTxO)
forall ctx. Gen (TxOut ctx)
genTxOut
  let (UTxO
confirmedUTxO', UTxO
utxoToDecommit') = UTxO -> (UTxO, UTxO)
splitUTxO UTxO
someUtxo
  ConfirmedSnapshot Tx
contestSnapshot <- HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType Tx
-> Maybe (UTxOType Tx)
-> Maybe (UTxOType Tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotVersion
-> SnapshotNumber
-> UTxOType tx
-> Maybe (UTxOType tx)
-> Maybe (UTxOType tx)
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotVersion
version (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) UTxOType Tx
UTxO
confirmedUTxO' Maybe (UTxOType Tx)
Maybe UTxO
forall a. Maybe a
Nothing (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToDecommit') (HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys HydraContext
ctx)
  PointInTime
contestPointInTime <- UTCTime -> Gen PointInTime
genPointInTimeBefore (ClosedState -> UTCTime
getContestationDeadline ClosedState
stClosed)
  (HydraContext, PointInTime, ClosedState, UTxO, Tx)
-> Gen (HydraContext, PointInTime, ClosedState, UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraContext
ctx, PointInTime
closePointInTime, ClosedState
stClosed, UTxO
forall a. Monoid a => a
mempty, HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
unsafeContest ChainContext
cctx UTxO
utxo HeadId
headId ContestationPeriod
cp SnapshotVersion
version ConfirmedSnapshot Tx
contestSnapshot PointInTime
contestPointInTime)

genFanoutTx :: Int -> Int -> Gen (HydraContext, ClosedState, UTxO, Tx)
genFanoutTx :: Int -> Int -> Gen (HydraContext, ClosedState, UTxO, Tx)
genFanoutTx Int
numParties Int
numOutputs = do
  HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
numParties
  UTxO
utxo <- Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
numOutputs
  let (UTxO
inHead', UTxO
toDecommit') = UTxO -> (UTxO, UTxO)
splitUTxO UTxO
utxo
  (SnapshotNumber
_, UTxO
toFanout, Maybe UTxO
toDecommit, stClosed :: ClosedState
stClosed@ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}) <- HydraContext
-> UTxO
-> Maybe UTxO
-> Gen (SnapshotNumber, UTxO, Maybe UTxO, ClosedState)
genStClosed HydraContext
ctx UTxO
inHead' (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
toDecommit')
  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, UTxO, Tx)
-> Gen (HydraContext, ClosedState, UTxO, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraContext
ctx, ClosedState
stClosed, UTxO
forall a. Monoid a => a
mempty, HasCallStack =>
ChainContext -> UTxO -> TxIn -> UTxO -> Maybe UTxO -> SlotNo -> Tx
ChainContext -> UTxO -> TxIn -> UTxO -> Maybe UTxO -> SlotNo -> Tx
unsafeFanout ChainContext
cctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
toFanout Maybe UTxO
toDecommit 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
utxoToCollect, (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 ->
  Maybe UTxO ->
  Gen (SnapshotNumber, UTxO, Maybe UTxO, ClosedState)
genStClosed :: HydraContext
-> UTxO
-> Maybe UTxO
-> Gen (SnapshotNumber, UTxO, Maybe UTxO, ClosedState)
genStClosed HydraContext
ctx UTxO
utxo Maybe UTxO
utxoToDecommit = 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, Maybe UTxO
toDecommit, SnapshotVersion
v) = case ConfirmedSnapshot Tx
confirmed of
        InitialSnapshot{} ->
          ( SnapshotNumber
0
          , InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId, $sel:initialUTxO:InitialSnapshot :: UTxOType Tx
initialUTxO = UTxOType Tx
UTxO
u0}
          , UTxO
u0
          , Maybe UTxO
forall a. Maybe a
Nothing
          , SnapshotVersion
0
          )
        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, utxoToDecommit}
              , MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
signatures
              }
          , UTxO
utxo
          , Maybe UTxO
utxoToDecommit
          , Snapshot Tx -> SnapshotVersion
forall tx. Snapshot tx -> SnapshotVersion
version Snapshot Tx
snap
          )
  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
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
utxo' HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) SnapshotVersion
v ConfirmedSnapshot Tx
snapshot SlotNo
startSlot PointInTime
pointInTime
  (SnapshotNumber, UTxO, Maybe UTxO, ClosedState)
-> Gen (SnapshotNumber, UTxO, Maybe UTxO, ClosedState)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotNumber
sn, UTxO
toFanout, Maybe UTxO
toDecommit, (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

unsafeIncrement ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable 'UTxO'
  UTxO ->
  HeadId ->
  HeadParameters ->
  ConfirmedSnapshot Tx ->
  TxId ->
  SlotNo ->
  Tx
unsafeIncrement :: HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> TxId
-> SlotNo
-> Tx
unsafeIncrement ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
parameters ConfirmedSnapshot Tx
incrementingSnapshot TxId
depositedTxId SlotNo
slotNo =
  (IncrementTxError -> Tx)
-> (Tx -> Tx) -> Either IncrementTxError 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)
-> (IncrementTxError -> Text) -> IncrementTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IncrementTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either IncrementTxError Tx -> Tx)
-> Either IncrementTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> TxId
-> SlotNo
-> Either IncrementTxError Tx
increment ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
parameters ConfirmedSnapshot Tx
incrementingSnapshot TxId
depositedTxId SlotNo
slotNo

unsafeDecrement ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable 'UTxO'
  UTxO ->
  HeadId ->
  HeadParameters ->
  ConfirmedSnapshot Tx ->
  Tx
unsafeDecrement :: HasCallStack =>
ChainContext
-> UTxO -> HeadId -> HeadParameters -> ConfirmedSnapshot Tx -> Tx
unsafeDecrement ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
parameters ConfirmedSnapshot Tx
decrementingSnapshot =
  (DecrementTxError -> Tx)
-> (Tx -> Tx) -> Either DecrementTxError 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)
-> (DecrementTxError -> Text) -> DecrementTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecrementTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either DecrementTxError Tx -> Tx)
-> Either DecrementTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> Either DecrementTxError Tx
decrement ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
parameters ConfirmedSnapshot Tx
decrementingSnapshot

-- | Unsafe version of 'close' that throws an error if the transaction fails to build.
unsafeClose ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  HeadId ->
  HeadParameters ->
  SnapshotVersion ->
  ConfirmedSnapshot Tx ->
  SlotNo ->
  PointInTime ->
  Tx
unsafeClose :: HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters SnapshotVersion
openVersion 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
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters SnapshotVersion
openVersion 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

-- | Unsafe version of 'contest' that throws an error if the transaction fails to build.
unsafeContest ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  HeadId ->
  ContestationPeriod ->
  SnapshotVersion ->
  ConfirmedSnapshot Tx ->
  PointInTime ->
  Tx
unsafeContest :: HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
unsafeContest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod SnapshotVersion
openVersion ConfirmedSnapshot Tx
contestingSnapshot 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
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod SnapshotVersion
openVersion ConfirmedSnapshot Tx
contestingSnapshot PointInTime
pointInTime

unsafeFanout ::
  HasCallStack =>
  ChainContext ->
  -- | Spendable UTxO containing head, initial and commit outputs
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | Snapshot UTxO to fanout
  UTxO ->
  -- | Snapshot decommit UTxO to fanout
  Maybe UTxO ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  Tx
unsafeFanout :: HasCallStack =>
ChainContext -> UTxO -> TxIn -> UTxO -> Maybe UTxO -> SlotNo -> Tx
unsafeFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo Maybe UTxO
utxoToDecommit 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
-> Maybe UTxO
-> SlotNo
-> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo Maybe UTxO
utxoToDecommit 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} -> UTxOType Tx
UTxO
committed
        OnChainTx Tx
_ -> UTxO
forall a. Monoid a => a
mempty