{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Hydra.Chain.Direct.State where
import Hydra.Prelude hiding (init)
import Cardano.Api.UTxO qualified as UTxO
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Hydra.Cardano.Api (
AssetId (..),
AssetName (AssetName),
ChainPoint (..),
CtxUTxO,
Key (SigningKey, VerificationKey, verificationKeyHash),
KeyWitnessInCtx (..),
NetworkId (Mainnet, Testnet),
NetworkMagic (NetworkMagic),
PaymentKey,
PlutusScriptV2,
PolicyId,
Quantity (..),
SerialiseAsRawBytes (serialiseToRawBytes),
SlotNo (SlotNo),
Tx,
TxIn,
TxOut,
UTxO,
UTxO' (UTxO),
WitCtxTxIn,
Witness,
chainPointToSlotNo,
fromPlutusScript,
fromScriptData,
genTxIn,
isScriptTxOut,
modifyTxOutValue,
selectAsset,
selectLovelace,
toTxContext,
txIns',
txOutReferenceScript,
txOutScriptData,
txOutValue,
valueFromList,
valueToList,
pattern ByronAddressInEra,
pattern KeyWitness,
pattern ReferenceScript,
pattern ReferenceScriptNone,
pattern ShelleyAddressInEra,
pattern TxOut,
)
import Hydra.Chain (
ChainStateType,
HeadParameters (..),
IsChainState (..),
OnChainTx (..),
PostTxError (..),
maxMainnetLovelace,
maximumNumberOfParties,
)
import Hydra.Chain.Direct.ScriptRegistry (
ScriptRegistry (..),
genScriptRegistry,
registryUTxO,
)
import Hydra.Chain.Direct.TimeHandle (PointInTime)
import Hydra.Chain.Direct.Tx (
AbortTxError (..),
CloseObservation (..),
CloseTxError (..),
ClosedThreadOutput (..),
ClosingSnapshot (..),
CollectComObservation (..),
CommitObservation (..),
ContestTxError (..),
FanoutTxError (..),
InitObservation (..),
InitialThreadOutput (..),
NotAnInitReason,
OpenThreadOutput (..),
UTxOHash (UTxOHash),
abortTx,
closeTx,
collectComTx,
commitTx,
contestTx,
fanoutTx,
headIdToPolicyId,
initTx,
observeCloseTx,
observeCollectComTx,
observeCommitTx,
observeInitTx,
txInToHeadSeed,
verificationKeyToOnChainId,
)
import Hydra.ContestationPeriod (ContestationPeriod, toChain)
import Hydra.ContestationPeriod qualified as ContestationPeriod
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Contract.Initial qualified as Initial
import Hydra.Crypto (HydraKey)
import Hydra.HeadId (HeadId (..))
import Hydra.Ledger (ChainSlot (ChainSlot), IsTx (hashUTxO))
import Hydra.Ledger.Cardano (genOneUTxOFor, genUTxOAdaOnlyOfSize, genVerificationKey)
import Hydra.Ledger.Cardano.Evaluate (genPointInTimeBefore, genValidityBoundsFromContestationPeriod, slotLength, systemStart)
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime)
import Hydra.OnChainId (OnChainId)
import Hydra.Party (Party, deriveParty, partyToChain)
import Hydra.Plutus.Extras (posixToUTCTime)
import Hydra.Snapshot (
ConfirmedSnapshot (..),
Snapshot (..),
SnapshotNumber,
genConfirmedSnapshot,
getSnapshot,
)
import Test.QuickCheck (choose, frequency, oneof, vector)
import Test.QuickCheck.Gen (elements)
import Test.QuickCheck.Modifiers (Positive (Positive))
class HasKnownUTxO a where
getKnownUTxO :: a -> UTxO
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
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
data ChainTransition
= Init
| Abort
| Commit
| Collect
| Close
| Contest
| Fanout
deriving stock (ChainTransition -> ChainTransition -> Bool
(ChainTransition -> ChainTransition -> Bool)
-> (ChainTransition -> ChainTransition -> Bool)
-> Eq ChainTransition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainTransition -> ChainTransition -> Bool
== :: ChainTransition -> ChainTransition -> Bool
$c/= :: ChainTransition -> ChainTransition -> Bool
/= :: ChainTransition -> ChainTransition -> Bool
Eq, Int -> ChainTransition -> ShowS
[ChainTransition] -> ShowS
ChainTransition -> String
(Int -> ChainTransition -> ShowS)
-> (ChainTransition -> String)
-> ([ChainTransition] -> ShowS)
-> Show ChainTransition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainTransition -> ShowS
showsPrec :: Int -> ChainTransition -> ShowS
$cshow :: ChainTransition -> String
show :: ChainTransition -> String
$cshowList :: [ChainTransition] -> ShowS
showList :: [ChainTransition] -> ShowS
Show, Int -> ChainTransition
ChainTransition -> Int
ChainTransition -> [ChainTransition]
ChainTransition -> ChainTransition
ChainTransition -> ChainTransition -> [ChainTransition]
ChainTransition
-> ChainTransition -> ChainTransition -> [ChainTransition]
(ChainTransition -> ChainTransition)
-> (ChainTransition -> ChainTransition)
-> (Int -> ChainTransition)
-> (ChainTransition -> Int)
-> (ChainTransition -> [ChainTransition])
-> (ChainTransition -> ChainTransition -> [ChainTransition])
-> (ChainTransition -> ChainTransition -> [ChainTransition])
-> (ChainTransition
-> ChainTransition -> ChainTransition -> [ChainTransition])
-> Enum ChainTransition
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ChainTransition -> ChainTransition
succ :: ChainTransition -> ChainTransition
$cpred :: ChainTransition -> ChainTransition
pred :: ChainTransition -> ChainTransition
$ctoEnum :: Int -> ChainTransition
toEnum :: Int -> ChainTransition
$cfromEnum :: ChainTransition -> Int
fromEnum :: ChainTransition -> Int
$cenumFrom :: ChainTransition -> [ChainTransition]
enumFrom :: ChainTransition -> [ChainTransition]
$cenumFromThen :: ChainTransition -> ChainTransition -> [ChainTransition]
enumFromThen :: ChainTransition -> ChainTransition -> [ChainTransition]
$cenumFromTo :: ChainTransition -> ChainTransition -> [ChainTransition]
enumFromTo :: ChainTransition -> ChainTransition -> [ChainTransition]
$cenumFromThenTo :: ChainTransition
-> ChainTransition -> ChainTransition -> [ChainTransition]
enumFromThenTo :: ChainTransition
-> ChainTransition -> ChainTransition -> [ChainTransition]
Enum, ChainTransition
ChainTransition -> ChainTransition -> Bounded ChainTransition
forall a. a -> a -> Bounded a
$cminBound :: ChainTransition
minBound :: ChainTransition
$cmaxBound :: ChainTransition
maxBound :: ChainTransition
Bounded)
data ChainState
=
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
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
}
data ChainContext = ChainContext
{ ChainContext -> NetworkId
networkId :: NetworkId
, ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
, ChainContext -> Party
ownParty :: Party
, ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
}
deriving stock (ChainContext -> ChainContext -> Bool
(ChainContext -> ChainContext -> Bool)
-> (ChainContext -> ChainContext -> Bool) -> Eq ChainContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainContext -> ChainContext -> Bool
== :: ChainContext -> ChainContext -> Bool
$c/= :: ChainContext -> ChainContext -> Bool
/= :: ChainContext -> ChainContext -> Bool
Eq, Int -> ChainContext -> ShowS
[ChainContext] -> ShowS
ChainContext -> String
(Int -> ChainContext -> ShowS)
-> (ChainContext -> String)
-> ([ChainContext] -> ShowS)
-> Show ChainContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainContext -> ShowS
showsPrec :: Int -> ChainContext -> ShowS
$cshow :: ChainContext -> String
show :: ChainContext -> String
$cshowList :: [ChainContext] -> ShowS
showList :: [ChainContext] -> ShowS
Show, (forall x. ChainContext -> Rep ChainContext x)
-> (forall x. Rep ChainContext x -> ChainContext)
-> Generic ChainContext
forall x. Rep ChainContext x -> ChainContext
forall x. ChainContext -> Rep ChainContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainContext -> Rep ChainContext x
from :: forall x. ChainContext -> Rep ChainContext x
$cto :: forall x. Rep ChainContext x -> ChainContext
to :: forall x. Rep ChainContext x -> ChainContext
Generic)
deriving anyclass ([ChainContext] -> Value
[ChainContext] -> Encoding
ChainContext -> Bool
ChainContext -> Value
ChainContext -> Encoding
(ChainContext -> Value)
-> (ChainContext -> Encoding)
-> ([ChainContext] -> Value)
-> ([ChainContext] -> Encoding)
-> (ChainContext -> Bool)
-> ToJSON ChainContext
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ChainContext -> Value
toJSON :: ChainContext -> Value
$ctoEncoding :: ChainContext -> Encoding
toEncoding :: ChainContext -> Encoding
$ctoJSONList :: [ChainContext] -> Value
toJSONList :: [ChainContext] -> Value
$ctoEncodingList :: [ChainContext] -> Encoding
toEncodingList :: [ChainContext] -> Encoding
$comitField :: ChainContext -> Bool
omitField :: ChainContext -> Bool
ToJSON, Maybe ChainContext
Value -> Parser [ChainContext]
Value -> Parser ChainContext
(Value -> Parser ChainContext)
-> (Value -> Parser [ChainContext])
-> Maybe ChainContext
-> FromJSON ChainContext
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ChainContext
parseJSON :: Value -> Parser ChainContext
$cparseJSONList :: Value -> Parser [ChainContext]
parseJSONList :: Value -> Parser [ChainContext]
$comittedField :: Maybe ChainContext
omittedField :: Maybe ChainContext
FromJSON)
instance HasKnownUTxO ChainContext where
getKnownUTxO :: ChainContext -> UTxO
getKnownUTxO ChainContext{ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry
instance Arbitrary ChainContext where
arbitrary :: Gen ChainContext
arbitrary = do
NetworkId
networkId <- NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId)
-> (Word32 -> NetworkMagic) -> Word32 -> NetworkId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkId) -> Gen Word32 -> Gen NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
VerificationKey PaymentKey
ownVerificationKey <- Gen (VerificationKey PaymentKey)
genVerificationKey
[Party]
otherParties <- Gen [Party]
forall a. Arbitrary a => Gen a
arbitrary
Party
ownParty <- [Party] -> Gen Party
forall a. [a] -> Gen a
elements [Party]
otherParties
ScriptRegistry
scriptRegistry <- Gen ScriptRegistry
genScriptRegistry
ChainContext -> Gen ChainContext
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
ChainContext
{ NetworkId
$sel:networkId:ChainContext :: NetworkId
networkId :: NetworkId
networkId
, VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey
, Party
$sel:ownParty:ChainContext :: Party
ownParty :: Party
ownParty
, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry
}
data InitialState = InitialState
{ InitialState -> InitialThreadOutput
initialThreadOutput :: InitialThreadOutput
, InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialInitials :: [(TxIn, TxOut CtxUTxO)]
, InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialCommits :: [(TxIn, TxOut CtxUTxO)]
, InitialState -> HeadId
headId :: HeadId
, InitialState -> TxIn
seedTxIn :: TxIn
}
deriving stock (InitialState -> InitialState -> Bool
(InitialState -> InitialState -> Bool)
-> (InitialState -> InitialState -> Bool) -> Eq InitialState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InitialState -> InitialState -> Bool
== :: InitialState -> InitialState -> Bool
$c/= :: InitialState -> InitialState -> Bool
/= :: InitialState -> InitialState -> Bool
Eq, Int -> InitialState -> ShowS
[InitialState] -> ShowS
InitialState -> String
(Int -> InitialState -> ShowS)
-> (InitialState -> String)
-> ([InitialState] -> ShowS)
-> Show InitialState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitialState -> ShowS
showsPrec :: Int -> InitialState -> ShowS
$cshow :: InitialState -> String
show :: InitialState -> String
$cshowList :: [InitialState] -> ShowS
showList :: [InitialState] -> ShowS
Show, (forall x. InitialState -> Rep InitialState x)
-> (forall x. Rep InitialState x -> InitialState)
-> Generic InitialState
forall x. Rep InitialState x -> InitialState
forall x. InitialState -> Rep InitialState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InitialState -> Rep InitialState x
from :: forall x. InitialState -> Rep InitialState x
$cto :: forall x. Rep InitialState x -> InitialState
to :: forall x. Rep InitialState x -> InitialState
Generic)
deriving anyclass ([InitialState] -> Value
[InitialState] -> Encoding
InitialState -> Bool
InitialState -> Value
InitialState -> Encoding
(InitialState -> Value)
-> (InitialState -> Encoding)
-> ([InitialState] -> Value)
-> ([InitialState] -> Encoding)
-> (InitialState -> Bool)
-> ToJSON InitialState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: InitialState -> Value
toJSON :: InitialState -> Value
$ctoEncoding :: InitialState -> Encoding
toEncoding :: InitialState -> Encoding
$ctoJSONList :: [InitialState] -> Value
toJSONList :: [InitialState] -> Value
$ctoEncodingList :: [InitialState] -> Encoding
toEncodingList :: [InitialState] -> Encoding
$comitField :: InitialState -> Bool
omitField :: InitialState -> Bool
ToJSON, Maybe InitialState
Value -> Parser [InitialState]
Value -> Parser InitialState
(Value -> Parser InitialState)
-> (Value -> Parser [InitialState])
-> Maybe InitialState
-> FromJSON InitialState
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser InitialState
parseJSON :: Value -> Parser InitialState
$cparseJSONList :: Value -> Parser [InitialState]
parseJSONList :: Value -> Parser [InitialState]
$comittedField :: Maybe InitialState
omittedField :: Maybe InitialState
FromJSON)
instance Arbitrary InitialState where
arbitrary :: Gen InitialState
arbitrary = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
(ChainContext, InitialState) -> InitialState
forall a b. (a, b) -> b
snd ((ChainContext, InitialState) -> InitialState)
-> Gen (ChainContext, InitialState) -> Gen InitialState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx
shrink :: InitialState -> [InitialState]
shrink = InitialState -> [InitialState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink
instance HasKnownUTxO InitialState where
getKnownUTxO :: InitialState -> UTxO
getKnownUTxO InitialState
st =
Map TxIn (TxOut CtxUTxO Era) -> UTxO
forall out. Map TxIn out -> UTxO' out
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO)
-> Map TxIn (TxOut CtxUTxO Era) -> UTxO
forall a b. (a -> b) -> a -> b
$
[(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$
(TxIn, TxOut CtxUTxO Era)
initialThreadUTxO (TxIn, TxOut CtxUTxO Era)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. a -> [a] -> [a]
: [(TxIn, TxOut CtxUTxO Era)]
initialCommits [(TxIn, TxOut CtxUTxO Era)]
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall a. Semigroup a => a -> a -> a
<> [(TxIn, TxOut CtxUTxO Era)]
initialInitials
where
InitialState
{ $sel:initialThreadOutput:InitialState :: InitialState -> InitialThreadOutput
initialThreadOutput = InitialThreadOutput{(TxIn, TxOut CtxUTxO Era)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:initialThreadUTxO:InitialThreadOutput :: InitialThreadOutput -> (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO}
, [(TxIn, TxOut CtxUTxO Era)]
$sel:initialInitials:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialInitials :: [(TxIn, TxOut CtxUTxO Era)]
initialInitials
, [(TxIn, TxOut CtxUTxO Era)]
$sel:initialCommits:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialCommits :: [(TxIn, TxOut CtxUTxO Era)]
initialCommits
} = InitialState
st
data OpenState = OpenState
{ OpenState -> OpenThreadOutput
openThreadOutput :: OpenThreadOutput
, OpenState -> HeadId
headId :: HeadId
, OpenState -> TxIn
seedTxIn :: TxIn
, OpenState -> UTxOHash
openUtxoHash :: UTxOHash
}
deriving stock (OpenState -> OpenState -> Bool
(OpenState -> OpenState -> Bool)
-> (OpenState -> OpenState -> Bool) -> Eq OpenState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenState -> OpenState -> Bool
== :: OpenState -> OpenState -> Bool
$c/= :: OpenState -> OpenState -> Bool
/= :: OpenState -> OpenState -> Bool
Eq, Int -> OpenState -> ShowS
[OpenState] -> ShowS
OpenState -> String
(Int -> OpenState -> ShowS)
-> (OpenState -> String)
-> ([OpenState] -> ShowS)
-> Show OpenState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenState -> ShowS
showsPrec :: Int -> OpenState -> ShowS
$cshow :: OpenState -> String
show :: OpenState -> String
$cshowList :: [OpenState] -> ShowS
showList :: [OpenState] -> ShowS
Show, (forall x. OpenState -> Rep OpenState x)
-> (forall x. Rep OpenState x -> OpenState) -> Generic OpenState
forall x. Rep OpenState x -> OpenState
forall x. OpenState -> Rep OpenState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. OpenState -> Rep OpenState x
from :: forall x. OpenState -> Rep OpenState x
$cto :: forall x. Rep OpenState x -> OpenState
to :: forall x. Rep OpenState x -> OpenState
Generic)
deriving anyclass ([OpenState] -> Value
[OpenState] -> Encoding
OpenState -> Bool
OpenState -> Value
OpenState -> Encoding
(OpenState -> Value)
-> (OpenState -> Encoding)
-> ([OpenState] -> Value)
-> ([OpenState] -> Encoding)
-> (OpenState -> Bool)
-> ToJSON OpenState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: OpenState -> Value
toJSON :: OpenState -> Value
$ctoEncoding :: OpenState -> Encoding
toEncoding :: OpenState -> Encoding
$ctoJSONList :: [OpenState] -> Value
toJSONList :: [OpenState] -> Value
$ctoEncodingList :: [OpenState] -> Encoding
toEncodingList :: [OpenState] -> Encoding
$comitField :: OpenState -> Bool
omitField :: OpenState -> Bool
ToJSON, Maybe OpenState
Value -> Parser [OpenState]
Value -> Parser OpenState
(Value -> Parser OpenState)
-> (Value -> Parser [OpenState])
-> Maybe OpenState
-> FromJSON OpenState
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser OpenState
parseJSON :: Value -> Parser OpenState
$cparseJSONList :: Value -> Parser [OpenState]
parseJSONList :: Value -> Parser [OpenState]
$comittedField :: Maybe OpenState
omittedField :: Maybe OpenState
FromJSON)
instance Arbitrary OpenState where
arbitrary :: Gen OpenState
arbitrary = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
(UTxO, OpenState) -> OpenState
forall a b. (a, b) -> b
snd ((UTxO, OpenState) -> OpenState)
-> Gen (UTxO, OpenState) -> Gen OpenState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
shrink :: OpenState -> [OpenState]
shrink = OpenState -> [OpenState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink
instance HasKnownUTxO OpenState where
getKnownUTxO :: OpenState -> UTxO
getKnownUTxO OpenState
st =
(TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO Era)
openThreadUTxO
where
OpenState
{ $sel:openThreadOutput:OpenState :: OpenState -> OpenThreadOutput
openThreadOutput = OpenThreadOutput{(TxIn, TxOut CtxUTxO Era)
openThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:openThreadUTxO:OpenThreadOutput :: OpenThreadOutput -> (TxIn, TxOut CtxUTxO Era)
openThreadUTxO}
} = OpenState
st
data ClosedState = ClosedState
{ ClosedState -> ClosedThreadOutput
closedThreadOutput :: ClosedThreadOutput
, ClosedState -> HeadId
headId :: HeadId
, ClosedState -> TxIn
seedTxIn :: TxIn
}
deriving stock (ClosedState -> ClosedState -> Bool
(ClosedState -> ClosedState -> Bool)
-> (ClosedState -> ClosedState -> Bool) -> Eq ClosedState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClosedState -> ClosedState -> Bool
== :: ClosedState -> ClosedState -> Bool
$c/= :: ClosedState -> ClosedState -> Bool
/= :: ClosedState -> ClosedState -> Bool
Eq, Int -> ClosedState -> ShowS
[ClosedState] -> ShowS
ClosedState -> String
(Int -> ClosedState -> ShowS)
-> (ClosedState -> String)
-> ([ClosedState] -> ShowS)
-> Show ClosedState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClosedState -> ShowS
showsPrec :: Int -> ClosedState -> ShowS
$cshow :: ClosedState -> String
show :: ClosedState -> String
$cshowList :: [ClosedState] -> ShowS
showList :: [ClosedState] -> ShowS
Show, (forall x. ClosedState -> Rep ClosedState x)
-> (forall x. Rep ClosedState x -> ClosedState)
-> Generic ClosedState
forall x. Rep ClosedState x -> ClosedState
forall x. ClosedState -> Rep ClosedState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClosedState -> Rep ClosedState x
from :: forall x. ClosedState -> Rep ClosedState x
$cto :: forall x. Rep ClosedState x -> ClosedState
to :: forall x. Rep ClosedState x -> ClosedState
Generic)
deriving anyclass ([ClosedState] -> Value
[ClosedState] -> Encoding
ClosedState -> Bool
ClosedState -> Value
ClosedState -> Encoding
(ClosedState -> Value)
-> (ClosedState -> Encoding)
-> ([ClosedState] -> Value)
-> ([ClosedState] -> Encoding)
-> (ClosedState -> Bool)
-> ToJSON ClosedState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ClosedState -> Value
toJSON :: ClosedState -> Value
$ctoEncoding :: ClosedState -> Encoding
toEncoding :: ClosedState -> Encoding
$ctoJSONList :: [ClosedState] -> Value
toJSONList :: [ClosedState] -> Value
$ctoEncodingList :: [ClosedState] -> Encoding
toEncodingList :: [ClosedState] -> Encoding
$comitField :: ClosedState -> Bool
omitField :: ClosedState -> Bool
ToJSON, Maybe ClosedState
Value -> Parser [ClosedState]
Value -> Parser ClosedState
(Value -> Parser ClosedState)
-> (Value -> Parser [ClosedState])
-> Maybe ClosedState
-> FromJSON ClosedState
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ClosedState
parseJSON :: Value -> Parser ClosedState
$cparseJSONList :: Value -> Parser [ClosedState]
parseJSONList :: Value -> Parser [ClosedState]
$comittedField :: Maybe ClosedState
omittedField :: Maybe ClosedState
FromJSON)
instance Arbitrary ClosedState where
arbitrary :: Gen ClosedState
arbitrary = do
(HydraContext
_, ClosedState
st, Tx
_) <- Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx Int
maxGenParties Int
maxGenAssets
ClosedState -> Gen ClosedState
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosedState
st
shrink :: ClosedState -> [ClosedState]
shrink = ClosedState -> [ClosedState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink
instance HasKnownUTxO ClosedState where
getKnownUTxO :: ClosedState -> UTxO
getKnownUTxO ClosedState
st =
(TxIn, TxOut CtxUTxO Era) -> UTxO
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO
where
ClosedState
{ $sel:closedThreadOutput:ClosedState :: ClosedState -> ClosedThreadOutput
closedThreadOutput = ClosedThreadOutput{(TxIn, TxOut CtxUTxO Era)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:closedThreadUTxO:ClosedThreadOutput :: ClosedThreadOutput -> (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO}
} = ClosedState
st
initialize ::
ChainContext ->
TxIn ->
[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
commit ::
ChainContext ->
HeadId ->
UTxO ->
UTxO ->
Either (PostTxError Tx) Tx
commit :: ChainContext
-> HeadId -> UTxO -> UTxO -> Either (PostTxError Tx) Tx
commit ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO
utxoToCommit =
ChainContext
-> HeadId
-> UTxO
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO (UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx)
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
forall a b. (a -> b) -> a -> b
$ UTxO
utxoToCommit UTxO
-> (TxOut CtxUTxO Era -> (TxOut CtxUTxO Era, Witness WitCtxTxIn))
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)
commit' ::
ChainContext ->
HeadId ->
UTxO ->
UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) ->
Either (PostTxError Tx) Tx
commit' :: ChainContext
-> HeadId
-> UTxO
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
utxoToCommit = do
PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId
-> PostTxError Tx -> Either (PostTxError Tx) PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadId{HeadId
headId :: HeadId
$sel:headId:NoSeedInput :: HeadId
headId}
(TxIn
i, TxOut CtxUTxO Era
o) <- PolicyId -> Maybe (TxIn, TxOut CtxUTxO Era)
ownInitial PolicyId
pid Maybe (TxIn, TxOut CtxUTxO Era)
-> PostTxError Tx
-> Either (PostTxError Tx) (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> CannotFindOwnInitial{$sel:knownUTxO:NoSeedInput :: UTxOType Tx
knownUTxO = UTxO
UTxOType Tx
spendableUTxO}
let utxo :: UTxO
utxo = (TxOut CtxUTxO Era, Witness WitCtxTxIn) -> TxOut CtxUTxO Era
forall a b. (a, b) -> a
fst ((TxOut CtxUTxO Era, Witness WitCtxTxIn) -> TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn) -> UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
utxoToCommit
UTxO -> Either (PostTxError Tx) ()
rejectByronAddress UTxO
utxo
UTxO -> Either (PostTxError Tx) ()
rejectReferenceScripts UTxO
utxo
NetworkId -> UTxO -> Either (PostTxError Tx) ()
rejectMoreThanMainnetLimit NetworkId
networkId UTxO
utxo
Tx -> Either (PostTxError Tx) Tx
forall a. a -> Either (PostTxError Tx) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either (PostTxError Tx) Tx)
-> Tx -> Either (PostTxError Tx) Tx
forall a b. (a -> b) -> a -> b
$ NetworkId
-> ScriptRegistry
-> HeadId
-> Party
-> UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
-> (TxIn, TxOut CtxUTxO Era, Hash PaymentKey)
-> Tx
commitTx NetworkId
networkId ScriptRegistry
scriptRegistry HeadId
headId Party
ownParty UTxO' (TxOut CtxUTxO Era, Witness WitCtxTxIn)
utxoToCommit (TxIn
i, TxOut CtxUTxO Era
o, Hash PaymentKey
vkh)
where
ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId, Party
$sel:ownParty:ChainContext :: ChainContext -> Party
ownParty :: Party
ownParty, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry, VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey} = ChainContext
ctx
vkh :: Hash PaymentKey
vkh = VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
ownVerificationKey
ownInitial :: PolicyId -> Maybe (TxIn, TxOut CtxUTxO Era)
ownInitial PolicyId
pid =
(TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PolicyId -> Value -> Bool
hasMatchingPT PolicyId
pid (Value -> Bool)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) UTxO
spendableUTxO
hasMatchingPT :: PolicyId -> Value -> Bool
hasMatchingPT PolicyId
pid Value
val =
Value -> AssetId -> Quantity
selectAsset Value
val (PolicyId -> AssetName -> AssetId
AssetId PolicyId
pid (ByteString -> AssetName
AssetName (Hash PaymentKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes Hash PaymentKey
vkh))) Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1
rejectByronAddress :: UTxO -> Either (PostTxError Tx) ()
rejectByronAddress :: UTxO -> Either (PostTxError Tx) ()
rejectByronAddress UTxO
u = do
UTxO
-> (TxOut CtxUTxO Era -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ UTxO
u ((TxOut CtxUTxO Era -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) ())
-> (TxOut CtxUTxO Era -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$ \case
(TxOut (ByronAddressInEra Address ByronAddr
addr) Value
_ TxOutDatum CtxUTxO
_ ReferenceScript
_) ->
PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left (Address ByronAddr -> PostTxError Tx
forall tx. Address ByronAddr -> PostTxError tx
UnsupportedLegacyOutput Address ByronAddr
addr)
(TxOut ShelleyAddressInEra{} Value
_ TxOutDatum CtxUTxO
_ ReferenceScript
_) ->
() -> Either (PostTxError Tx) ()
forall a b. b -> Either a b
Right ()
rejectReferenceScripts :: UTxO -> Either (PostTxError Tx) ()
rejectReferenceScripts :: UTxO -> Either (PostTxError Tx) ()
rejectReferenceScripts UTxO
u =
Bool -> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((TxOut CtxUTxO Era -> Bool) -> UTxO -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TxOut CtxUTxO Era -> Bool
forall {ctx}. TxOut ctx -> Bool
hasReferenceScript UTxO
u) (Either (PostTxError Tx) () -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left PostTxError Tx
forall tx. PostTxError tx
CannotCommitReferenceScript
where
hasReferenceScript :: TxOut ctx -> Bool
hasReferenceScript TxOut ctx
out =
case TxOut ctx -> ReferenceScript
forall ctx. TxOut ctx -> ReferenceScript
txOutReferenceScript TxOut ctx
out of
ReferenceScript{} -> Bool
True
ReferenceScript
ReferenceScriptNone -> Bool
False
rejectMoreThanMainnetLimit :: NetworkId -> UTxO -> Either (PostTxError Tx) ()
rejectMoreThanMainnetLimit :: NetworkId -> UTxO -> Either (PostTxError Tx) ()
rejectMoreThanMainnetLimit NetworkId
network UTxO
u = do
Bool -> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NetworkId
network NetworkId -> NetworkId -> Bool
forall a. Eq a => a -> a -> Bool
== NetworkId
Mainnet Bool -> Bool -> Bool
&& Coin
lovelaceAmt Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
maxMainnetLovelace) (Either (PostTxError Tx) () -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left (PostTxError Tx -> Either (PostTxError Tx) ())
-> PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
Coin -> Coin -> PostTxError Tx
forall tx. Coin -> Coin -> PostTxError tx
CommittedTooMuchADAForMainnet Coin
lovelaceAmt Coin
maxMainnetLovelace
where
lovelaceAmt :: Coin
lovelaceAmt = (TxOut CtxUTxO Era -> Coin) -> UTxO -> Coin
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Value -> Coin
selectLovelace (Value -> Coin)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) UTxO
u
abort ::
ChainContext ->
TxIn ->
UTxO ->
UTxO ->
Either AbortTxError Tx
abort :: ChainContext -> TxIn -> UTxO -> UTxO -> Either AbortTxError Tx
abort ChainContext
ctx TxIn
seedTxIn UTxO
spendableUTxO UTxO
committedUTxO = do
(TxIn, TxOut CtxUTxO Era)
headUTxO <-
Either AbortTxError (TxIn, TxOut CtxUTxO Era)
-> ((TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era))
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AbortTxError -> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall a b. a -> Either a b
Left AbortTxError
CannotFindHeadOutputToAbort) (TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall a. a -> Either AbortTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era))
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> Either AbortTxError (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$
(TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) UTxO
utxoOfThisHead'
UTxO
-> ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, TxOut CtxUTxO Era)
-> PlutusScript PlutusScriptV2
-> Map TxIn (TxOut CtxUTxO Era)
-> Map TxIn (TxOut CtxUTxO Era)
-> Either AbortTxError Tx
abortTx UTxO
committedUTxO ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey (TxIn, TxOut CtxUTxO Era)
headUTxO PlutusScript PlutusScriptV2
headTokenScript Map TxIn (TxOut CtxUTxO Era)
initials Map TxIn (TxOut CtxUTxO Era)
commits
where
utxoOfThisHead' :: UTxO
utxoOfThisHead' = PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
spendableUTxO
initials :: Map TxIn (TxOut CtxUTxO Era)
initials =
UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (UTxO -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
initialScript) UTxO
utxoOfThisHead'
commits :: Map TxIn (TxOut CtxUTxO Era)
commits =
UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (UTxO -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
commitScript) UTxO
utxoOfThisHead'
commitScript :: PlutusScript PlutusScriptV2
commitScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Commit.validatorScript
headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
initialScript :: PlutusScript PlutusScriptV2
initialScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Initial.validatorScript
headTokenScript :: PlutusScript PlutusScriptV2
headTokenScript = TxIn -> PlutusScript PlutusScriptV2
mkHeadTokenScript TxIn
seedTxIn
ChainContext{VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx
data CollectTxError
= InvalidHeadIdInCollect {CollectTxError -> HeadId
headId :: HeadId}
| CannotFindHeadOutputToCollect
deriving stock (Int -> CollectTxError -> ShowS
[CollectTxError] -> ShowS
CollectTxError -> String
(Int -> CollectTxError -> ShowS)
-> (CollectTxError -> String)
-> ([CollectTxError] -> ShowS)
-> Show CollectTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CollectTxError -> ShowS
showsPrec :: Int -> CollectTxError -> ShowS
$cshow :: CollectTxError -> String
show :: CollectTxError -> String
$cshowList :: [CollectTxError] -> ShowS
showList :: [CollectTxError] -> ShowS
Show)
collect ::
ChainContext ->
HeadId ->
HeadParameters ->
UTxO ->
UTxO ->
Either CollectTxError Tx
collect :: ChainContext
-> HeadId
-> HeadParameters
-> UTxO
-> UTxO
-> Either CollectTxError Tx
collect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
utxoToCollect UTxO
spendableUTxO = do
PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> CollectTxError -> Either CollectTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInCollect{HeadId
$sel:headId:InvalidHeadIdInCollect :: HeadId
headId :: HeadId
headId}
let utxoOfThisHead' :: UTxO
utxoOfThisHead' = PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO
(TxIn, TxOut CtxUTxO Era)
headUTxO <- (TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) UTxO
utxoOfThisHead' Maybe (TxIn, TxOut CtxUTxO Era)
-> CollectTxError
-> Either CollectTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> CollectTxError
CannotFindHeadOutputToCollect
let commits :: Map TxIn (TxOut CtxUTxO Era)
commits = UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (UTxO -> Map TxIn (TxOut CtxUTxO Era))
-> UTxO -> Map TxIn (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
commitScript) UTxO
utxoOfThisHead'
Tx -> Either CollectTxError Tx
forall a. a -> Either CollectTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either CollectTxError Tx) -> Tx -> Either CollectTxError Tx
forall a b. (a -> b) -> a -> b
$
NetworkId
-> ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> HeadParameters
-> (TxIn, TxOut CtxUTxO Era)
-> Map TxIn (TxOut CtxUTxO Era)
-> UTxO
-> Tx
collectComTx NetworkId
networkId ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey HeadId
headId HeadParameters
headParameters (TxIn, TxOut CtxUTxO Era)
headUTxO Map TxIn (TxOut CtxUTxO Era)
commits UTxO
utxoToCollect
where
headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
commitScript :: PlutusScript PlutusScriptV2
commitScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Commit.validatorScript
ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId, VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx
close ::
ChainContext ->
UTxO ->
HeadId ->
HeadParameters ->
ConfirmedSnapshot Tx ->
SlotNo ->
PointInTime ->
Either CloseTxError Tx
close :: ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod} ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo PointInTime
pointInTime = do
PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> CloseTxError -> Either CloseTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInClose{HeadId
headId :: HeadId
$sel:headId:InvalidHeadIdInClose :: HeadId
headId}
(TxIn, TxOut CtxUTxO Era)
headUTxO <-
(TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO)
Maybe (TxIn, TxOut CtxUTxO Era)
-> CloseTxError -> Either CloseTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> CloseTxError
CannotFindHeadOutputToClose
let openThreadOutput :: OpenThreadOutput
openThreadOutput =
OpenThreadOutput
{ $sel:openThreadUTxO:OpenThreadOutput :: (TxIn, TxOut CtxUTxO Era)
openThreadUTxO = (TxIn, TxOut CtxUTxO Era)
headUTxO
, $sel:openContestationPeriod:OpenThreadOutput :: ContestationPeriod
openContestationPeriod = ContestationPeriod -> ContestationPeriod
ContestationPeriod.toChain ContestationPeriod
contestationPeriod
, $sel:openParties:OpenThreadOutput :: [Party]
openParties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
}
Tx -> Either CloseTxError Tx
forall a. a -> Either CloseTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either CloseTxError Tx) -> Tx -> Either CloseTxError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> VerificationKey PaymentKey
-> ClosingSnapshot
-> SlotNo
-> PointInTime
-> OpenThreadOutput
-> HeadId
-> Tx
closeTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey ClosingSnapshot
closingSnapshot SlotNo
startSlotNo PointInTime
pointInTime OpenThreadOutput
openThreadOutput HeadId
headId
where
headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
closingSnapshot :: ClosingSnapshot
closingSnapshot = case ConfirmedSnapshot Tx
confirmedSnapshot of
InitialSnapshot{UTxOType Tx
initialUTxO :: UTxOType Tx
$sel:initialUTxO:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> UTxOType tx
initialUTxO} -> CloseWithInitialSnapshot{$sel:openUtxoHash:CloseWithInitialSnapshot :: UTxOHash
openUtxoHash = ByteString -> UTxOHash
UTxOHash (ByteString -> UTxOHash) -> ByteString -> UTxOHash
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxOType Tx
initialUTxO}
ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot{SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo}, MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures} ->
CloseWithConfirmedSnapshot
{ $sel:snapshotNumber:CloseWithInitialSnapshot :: SnapshotNumber
snapshotNumber = SnapshotNumber
number
, $sel:closeUtxoHash:CloseWithInitialSnapshot :: UTxOHash
closeUtxoHash = ByteString -> UTxOHash
UTxOHash (ByteString -> UTxOHash) -> ByteString -> UTxOHash
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxOType Tx
utxo
, MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:CloseWithInitialSnapshot :: MultiSignature (Snapshot Tx)
signatures
}
ChainContext{VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx
contest ::
ChainContext ->
UTxO ->
HeadId ->
ContestationPeriod ->
ConfirmedSnapshot Tx ->
PointInTime ->
Either ContestTxError Tx
contest :: ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot PointInTime
pointInTime = do
PolicyId
pid <- HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> ContestTxError -> Either ContestTxError PolicyId
forall a e. Maybe a -> e -> Either e a
?> InvalidHeadIdInContest{HeadId
headId :: HeadId
$sel:headId:InvalidHeadIdInContest :: HeadId
headId}
(TxIn, TxOut CtxUTxO Era)
headUTxO <-
(TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
pid UTxO
spendableUTxO)
Maybe (TxIn, TxOut CtxUTxO Era)
-> ContestTxError
-> Either ContestTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> ContestTxError
CannotFindHeadOutputToContest
ClosedThreadOutput
closedThreadOutput <- (TxIn, TxOut CtxUTxO Era)
-> Either ContestTxError ClosedThreadOutput
checkHeadDatum (TxIn, TxOut CtxUTxO Era)
headUTxO
Tx -> Either ContestTxError Tx
forall a. a -> Either ContestTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either ContestTxError Tx) -> Tx -> Either ContestTxError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> VerificationKey PaymentKey
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> PointInTime
-> ClosedThreadOutput
-> HeadId
-> ContestationPeriod
-> Tx
contestTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
ownVerificationKey Snapshot Tx
sn MultiSignature (Snapshot Tx)
sigs PointInTime
pointInTime ClosedThreadOutput
closedThreadOutput HeadId
headId ContestationPeriod
contestationPeriod
where
checkHeadDatum :: (TxIn, TxOut CtxUTxO Era)
-> Either ContestTxError ClosedThreadOutput
checkHeadDatum headUTxO :: (TxIn, TxOut CtxUTxO Era)
headUTxO@(TxIn
_, TxOut CtxUTxO Era
headOutput) = do
HashableScriptData
headDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO Era
headOutput) Maybe HashableScriptData
-> ContestTxError -> Either ContestTxError HashableScriptData
forall a e. Maybe a -> e -> Either e a
?> ContestTxError
MissingHeadDatumInContest
State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
headDatum Maybe State -> ContestTxError -> Either ContestTxError State
forall a e. Maybe a -> e -> Either e a
?> ContestTxError
FailedToConvertFromScriptDataInContest
case State
datum of
Head.Closed{[PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters, [Party]
parties :: [Party]
$sel:parties:Initial :: State -> [Party]
parties, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline} -> do
let closedThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO = (TxIn, TxOut CtxUTxO Era)
headUTxO
closedParties :: [Party]
closedParties = [Party]
parties
closedContestationDeadline :: POSIXTime
closedContestationDeadline = POSIXTime
contestationDeadline
closedContesters :: [PubKeyHash]
closedContesters = [PubKeyHash]
contesters
ClosedThreadOutput -> Either ContestTxError ClosedThreadOutput
forall a. a -> Either ContestTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClosedThreadOutput -> Either ContestTxError ClosedThreadOutput)
-> ClosedThreadOutput -> Either ContestTxError ClosedThreadOutput
forall a b. (a -> b) -> a -> b
$
ClosedThreadOutput
{ (TxIn, TxOut CtxUTxO Era)
$sel:closedThreadUTxO:ClosedThreadOutput :: (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO
, [Party]
closedParties :: [Party]
$sel:closedParties:ClosedThreadOutput :: [Party]
closedParties
, POSIXTime
closedContestationDeadline :: POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: POSIXTime
closedContestationDeadline
, [PubKeyHash]
closedContesters :: [PubKeyHash]
$sel:closedContesters:ClosedThreadOutput :: [PubKeyHash]
closedContesters
}
State
_ -> ContestTxError -> Either ContestTxError ClosedThreadOutput
forall a b. a -> Either a b
Left ContestTxError
WrongDatumInContest
(Snapshot Tx
sn, MultiSignature (Snapshot Tx)
sigs) =
case ConfirmedSnapshot Tx
confirmedSnapshot of
ConfirmedSnapshot{MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot Tx)
signatures} -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot, MultiSignature (Snapshot Tx)
signatures)
ConfirmedSnapshot Tx
_ -> (ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmedSnapshot, MultiSignature (Snapshot Tx)
forall a. Monoid a => a
mempty)
ChainContext{VerificationKey PaymentKey
$sel:ownVerificationKey:ChainContext :: ChainContext -> VerificationKey PaymentKey
ownVerificationKey :: VerificationKey PaymentKey
ownVerificationKey, ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx
headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
fanout ::
ChainContext ->
UTxO ->
TxIn ->
UTxO ->
SlotNo ->
Either FanoutTxError Tx
fanout :: ChainContext
-> UTxO -> TxIn -> UTxO -> SlotNo -> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo SlotNo
deadlineSlotNo = do
(TxIn, TxOut CtxUTxO Era)
headUTxO <-
(TxOut CtxUTxO Era -> Bool)
-> UTxO -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (PlutusScript PlutusScriptV2 -> TxOut CtxUTxO Era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV2
headScript) (PolicyId -> UTxO -> UTxO
utxoOfThisHead (TxIn -> PolicyId
headPolicyId TxIn
seedTxIn) UTxO
spendableUTxO)
Maybe (TxIn, TxOut CtxUTxO Era)
-> FanoutTxError -> Either FanoutTxError (TxIn, TxOut CtxUTxO Era)
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
CannotFindHeadOutputToFanout
(TxIn, TxOut CtxUTxO Era)
closedThreadUTxO <- (TxIn, TxOut CtxUTxO Era)
-> Either FanoutTxError (TxIn, TxOut CtxUTxO Era)
forall {a} {era}.
(a, TxOut CtxUTxO era)
-> Either FanoutTxError (a, TxOut CtxUTxO era)
checkHeadDatum (TxIn, TxOut CtxUTxO Era)
headUTxO
Tx -> Either FanoutTxError Tx
forall a. a -> Either FanoutTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either FanoutTxError Tx) -> Tx -> Either FanoutTxError Tx
forall a b. (a -> b) -> a -> b
$ ScriptRegistry
-> UTxO
-> (TxIn, TxOut CtxUTxO Era)
-> SlotNo
-> PlutusScript PlutusScriptV2
-> Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO
utxo (TxIn, TxOut CtxUTxO Era)
closedThreadUTxO SlotNo
deadlineSlotNo PlutusScript PlutusScriptV2
headTokenScript
where
headTokenScript :: PlutusScript PlutusScriptV2
headTokenScript = TxIn -> PlutusScript PlutusScriptV2
mkHeadTokenScript TxIn
seedTxIn
ChainContext{ScriptRegistry
$sel:scriptRegistry:ChainContext :: ChainContext -> ScriptRegistry
scriptRegistry :: ScriptRegistry
scriptRegistry} = ChainContext
ctx
headScript :: PlutusScript PlutusScriptV2
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
checkHeadDatum :: (a, TxOut CtxUTxO era)
-> Either FanoutTxError (a, TxOut CtxUTxO era)
checkHeadDatum headUTxO :: (a, TxOut CtxUTxO era)
headUTxO@(a
_, TxOut CtxUTxO era
headOutput) = do
HashableScriptData
headDatum <-
TxOut CtxTx era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO era -> TxOut CtxTx era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO era
headOutput) Maybe HashableScriptData
-> FanoutTxError -> Either FanoutTxError HashableScriptData
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
MissingHeadDatumInFanout
State
datum <-
HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
headDatum Maybe State -> FanoutTxError -> Either FanoutTxError State
forall a e. Maybe a -> e -> Either e a
?> FanoutTxError
FailedToConvertFromScriptDataInFanout
case State
datum of
Head.Closed{} -> (a, TxOut CtxUTxO era)
-> Either FanoutTxError (a, TxOut CtxUTxO era)
forall a. a -> Either FanoutTxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, TxOut CtxUTxO era)
headUTxO
State
_ -> FanoutTxError -> Either FanoutTxError (a, TxOut CtxUTxO era)
forall a b. a -> Either a b
Left FanoutTxError
WrongDatumInFanout
utxoOfThisHead :: PolicyId -> UTxO -> UTxO
utxoOfThisHead :: PolicyId -> UTxO -> UTxO
utxoOfThisHead PolicyId
policy = (TxOut CtxUTxO Era -> Bool) -> UTxO -> UTxO
forall out. (out -> Bool) -> UTxO' out -> UTxO' out
UTxO.filter TxOut CtxUTxO Era -> Bool
hasHeadToken
where
hasHeadToken :: TxOut CtxUTxO Era -> Bool
hasHeadToken =
Maybe (AssetId, Quantity) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (AssetId, Quantity) -> Bool)
-> (TxOut CtxUTxO Era -> Maybe (AssetId, Quantity))
-> TxOut CtxUTxO Era
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> Bool)
-> [(AssetId, Quantity)] -> Maybe (AssetId, Quantity)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (AssetId, Quantity) -> Bool
isHeadToken ([(AssetId, Quantity)] -> Maybe (AssetId, Quantity))
-> (TxOut CtxUTxO Era -> [(AssetId, Quantity)])
-> TxOut CtxUTxO Era
-> Maybe (AssetId, Quantity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
valueToList (Value -> [(AssetId, Quantity)])
-> (TxOut CtxUTxO Era -> Value)
-> TxOut CtxUTxO Era
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue
isHeadToken :: (AssetId, Quantity) -> Bool
isHeadToken (AssetId
assetId, Quantity
quantity) =
case AssetId
assetId of
AssetId
AdaAssetId -> Bool
False
AssetId PolicyId
pid AssetName
_ -> PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
policy Bool -> Bool -> Bool
&& Quantity
quantity Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1
observeInit ::
ChainContext ->
[VerificationKey PaymentKey] ->
Tx ->
Either NotAnInitReason (OnChainTx Tx, InitialState)
observeInit :: ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> Either NotAnInitReason (OnChainTx Tx, InitialState)
observeInit ChainContext
_ctx [VerificationKey PaymentKey]
_allVerificationKeys Tx
tx = do
InitObservation
observation <- Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx
(OnChainTx Tx, InitialState)
-> Either NotAnInitReason (OnChainTx Tx, InitialState)
forall a. a -> Either NotAnInitReason a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InitObservation -> OnChainTx Tx
forall {tx}. InitObservation -> OnChainTx tx
toEvent InitObservation
observation, InitObservation -> InitialState
toState InitObservation
observation)
where
toEvent :: InitObservation -> OnChainTx tx
toEvent InitObservation{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:InitObservation :: InitObservation -> ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:InitObservation :: InitObservation -> [Party]
parties, HeadId
headId :: HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId, TxIn
seedTxIn :: TxIn
$sel:seedTxIn:InitObservation :: InitObservation -> TxIn
seedTxIn, [OnChainId]
participants :: [OnChainId]
$sel:participants:InitObservation :: InitObservation -> [OnChainId]
participants} =
OnInitTx
{ HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId
, $sel:headSeed:OnInitTx :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed TxIn
seedTxIn
, $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:HeadParameters :: [Party]
parties :: [Party]
parties}
, [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants
}
toState :: InitObservation -> InitialState
toState InitObservation{(TxIn, TxOut CtxUTxO Era)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
$sel:initialThreadUTxO:InitObservation :: InitObservation -> (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO, [Party]
$sel:parties:InitObservation :: InitObservation -> [Party]
parties :: [Party]
parties, ContestationPeriod
$sel:contestationPeriod:InitObservation :: InitObservation -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [(TxIn, TxOut CtxUTxO Era)]
initials :: [(TxIn, TxOut CtxUTxO Era)]
$sel:initials:InitObservation :: InitObservation -> [(TxIn, TxOut CtxUTxO Era)]
initials, HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId :: HeadId
headId, TxIn
$sel:seedTxIn:InitObservation :: InitObservation -> TxIn
seedTxIn :: TxIn
seedTxIn} =
InitialState
{ $sel:initialThreadOutput:InitialState :: InitialThreadOutput
initialThreadOutput =
InitialThreadOutput
{ (TxIn, TxOut CtxUTxO Era)
$sel:initialThreadUTxO:InitialThreadOutput :: (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO Era)
initialThreadUTxO
, $sel:initialParties:InitialThreadOutput :: [Party]
initialParties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
, $sel:initialContestationPeriod:InitialThreadOutput :: ContestationPeriod
initialContestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod
}
, $sel:initialInitials:InitialState :: [(TxIn, TxOut CtxUTxO Era)]
initialInitials = [(TxIn, TxOut CtxUTxO Era)]
initials
, $sel:initialCommits:InitialState :: [(TxIn, TxOut CtxUTxO Era)]
initialCommits = [(TxIn, TxOut CtxUTxO Era)]
forall a. Monoid a => a
mempty
, HeadId
$sel:headId:InitialState :: HeadId
headId :: HeadId
headId
, TxIn
$sel:seedTxIn:InitialState :: TxIn
seedTxIn :: TxIn
seedTxIn
}
observeCommit ::
ChainContext ->
InitialState ->
Tx ->
Maybe (OnChainTx Tx, InitialState)
observeCommit :: ChainContext
-> InitialState -> Tx -> Maybe (OnChainTx Tx, InitialState)
observeCommit ChainContext
ctx InitialState
st Tx
tx = do
let utxo :: UTxO
utxo = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
st
CommitObservation
observation <- NetworkId -> UTxO -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO
utxo Tx
tx
let CommitObservation{(TxIn, TxOut CtxUTxO Era)
commitOutput :: (TxIn, TxOut CtxUTxO Era)
$sel:commitOutput:CommitObservation :: CommitObservation -> (TxIn, TxOut CtxUTxO Era)
commitOutput, Party
party :: Party
$sel:party:CommitObservation :: CommitObservation -> Party
party, UTxO
committed :: UTxO
$sel:committed:CommitObservation :: CommitObservation -> UTxO
committed, $sel:headId:CommitObservation :: CommitObservation -> HeadId
headId = HeadId
commitHeadId} = CommitObservation
observation
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HeadId
commitHeadId HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
headId
let event :: OnChainTx Tx
event = OnCommitTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, Party
party :: Party
$sel:party:OnInitTx :: Party
party, UTxO
UTxOType Tx
committed :: UTxO
$sel:committed:OnInitTx :: UTxOType Tx
committed}
let st' :: InitialState
st' =
InitialState
st
{ initialInitials =
filter ((`notElem` txIns' tx) . fst) initialInitials
, initialCommits =
commitOutput : initialCommits
}
(OnChainTx Tx, InitialState) -> Maybe (OnChainTx Tx, InitialState)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainTx Tx
event, InitialState
st')
where
ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId} = ChainContext
ctx
InitialState
{ [(TxIn, TxOut CtxUTxO Era)]
$sel:initialCommits:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialCommits :: [(TxIn, TxOut CtxUTxO Era)]
initialCommits
, [(TxIn, TxOut CtxUTxO Era)]
$sel:initialInitials:InitialState :: InitialState -> [(TxIn, TxOut CtxUTxO Era)]
initialInitials :: [(TxIn, TxOut CtxUTxO Era)]
initialInitials
, HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId
} = InitialState
st
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)
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
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
maxGenParties :: Int
maxGenParties :: Int
maxGenParties = Int
3
maxGenAssets :: Int
maxGenAssets :: Int
maxGenAssets = Int
70
genChainState :: Gen ChainState
genChainState :: Gen ChainState
genChainState =
[Gen ChainState] -> Gen ChainState
forall a. [Gen a] -> Gen a
oneof
[ ChainState -> Gen ChainState
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainState
Idle
, InitialState -> ChainState
Initial (InitialState -> ChainState) -> Gen InitialState -> Gen ChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen InitialState
forall a. Arbitrary a => Gen a
arbitrary
, OpenState -> ChainState
Open (OpenState -> ChainState) -> Gen OpenState -> Gen ChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen OpenState
forall a. Arbitrary a => Gen a
arbitrary
, ClosedState -> ChainState
Closed (ClosedState -> ChainState) -> Gen ClosedState -> Gen ChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ClosedState
forall a. Arbitrary a => Gen a
arbitrary
]
genChainStateWithTx :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genChainStateWithTx :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genChainStateWithTx =
[Gen (ChainContext, ChainState, Tx, ChainTransition)]
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. [Gen a] -> Gen a
oneof
[ Gen (ChainContext, ChainState, Tx, ChainTransition)
genInitWithState
, Gen (ChainContext, ChainState, Tx, ChainTransition)
genAbortWithState
, Gen (ChainContext, ChainState, Tx, ChainTransition)
genCommitWithState
, Gen (ChainContext, ChainState, Tx, ChainTransition)
genCollectWithState
, Gen (ChainContext, ChainState, Tx, ChainTransition)
genCloseWithState
, Gen (ChainContext, ChainState, Tx, ChainTransition)
genContestWithState
, Gen (ChainContext, ChainState, Tx, ChainTransition)
genFanoutWithState
]
where
genInitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genInitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genInitWithState = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
TxIn
seedInput <- Gen TxIn
genTxIn
let tx :: Tx
tx = ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx TxIn
seedInput (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
(ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, ChainState
Idle, Tx
tx, ChainTransition
Init)
genAbortWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genAbortWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genAbortWithState = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
(ChainContext
cctx, InitialState
stInitial) <- HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx
let utxo :: UTxO
utxo = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial
InitialState{TxIn
$sel:seedTxIn:InitialState :: InitialState -> TxIn
seedTxIn :: TxIn
seedTxIn} = InitialState
stInitial
tx :: Tx
tx = HasCallStack => ChainContext -> TxIn -> UTxO -> UTxO -> Tx
ChainContext -> TxIn -> UTxO -> UTxO -> Tx
unsafeAbort ChainContext
cctx TxIn
seedTxIn UTxO
utxo UTxO
forall a. Monoid a => a
mempty
(ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState -> ChainState
Initial InitialState
stInitial, Tx
tx, ChainTransition
Abort)
genCommitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCommitWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCommitWithState = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
maxGenParties
(ChainContext
cctx, InitialState
stInitial) <- HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx
UTxO
utxo <- Gen UTxO
genCommit
let InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = InitialState
stInitial
let tx :: Tx
tx = HasCallStack => ChainContext -> HeadId -> UTxO -> UTxO -> Tx
ChainContext -> HeadId -> UTxO -> UTxO -> Tx
unsafeCommit ChainContext
cctx HeadId
headId (InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial) UTxO
utxo
(ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState -> ChainState
Initial InitialState
stInitial, Tx
tx, ChainTransition
Commit)
genCollectWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCollectWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCollectWithState = do
(ChainContext
ctx, [UTxO]
_, InitialState
st, Tx
tx) <- Gen (ChainContext, [UTxO], InitialState, Tx)
genCollectComTx
(ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, InitialState -> ChainState
Initial InitialState
st, Tx
tx, ChainTransition
Collect)
genCloseWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCloseWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genCloseWithState = do
(ChainContext
ctx, OpenState
st, Tx
tx, ConfirmedSnapshot Tx
_) <- Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
genCloseTx Int
maxGenParties
(ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, OpenState -> ChainState
Open OpenState
st, Tx
tx, ChainTransition
Close)
genContestWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genContestWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genContestWithState = do
(HydraContext
hctx, PointInTime
_, ClosedState
st, Tx
tx) <- Gen (HydraContext, PointInTime, ClosedState, Tx)
genContestTx
ChainContext
ctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
hctx
(ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, ClosedState -> ChainState
Closed ClosedState
st, Tx
tx, ChainTransition
Contest)
genFanoutWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genFanoutWithState :: Gen (ChainContext, ChainState, Tx, ChainTransition)
genFanoutWithState = do
Positive Int
numParties <- Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
Positive Int
numOutputs <- Gen (Positive Int)
forall a. Arbitrary a => Gen a
arbitrary
(HydraContext
hctx, ClosedState
st, Tx
tx) <- Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx Int
numParties Int
numOutputs
ChainContext
ctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
hctx
(ChainContext, ChainState, Tx, ChainTransition)
-> Gen (ChainContext, ChainState, Tx, ChainTransition)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
ctx, ClosedState -> ChainState
Closed ClosedState
st, Tx
tx, ChainTransition
Fanout)
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)
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
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
}
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
pickChainContext :: HydraContext -> Gen ChainContext
pickChainContext :: HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx =
HydraContext -> Gen [ChainContext]
deriveChainContexts HydraContext
ctx Gen [ChainContext]
-> ([ChainContext] -> Gen ChainContext) -> Gen ChainContext
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ChainContext] -> Gen ChainContext
forall a. [a] -> Gen a
elements
genStInitial ::
HydraContext ->
Gen (ChainContext, InitialState)
genStInitial :: HydraContext -> Gen (ChainContext, InitialState)
genStInitial HydraContext
ctx = do
TxIn
seedInput <- Gen TxIn
genTxIn
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
let txInit :: Tx
txInit = ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx TxIn
seedInput (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
let initState :: InitialState
initState = HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit
(ChainContext, InitialState) -> Gen (ChainContext, InitialState)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, InitialState
initState)
genInitTx ::
HydraContext ->
Gen Tx
genInitTx :: HydraContext -> Gen Tx
genInitTx HydraContext
ctx = do
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
TxIn
seedInput <- Gen TxIn
genTxIn
Tx -> Gen Tx
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Gen Tx) -> Tx -> Gen Tx
forall a b. (a -> b) -> a -> b
$ ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
cctx TxIn
seedInput (HydraContext -> [OnChainId]
ctxParticipants HydraContext
ctx) (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx)
genCommits ::
HydraContext ->
Tx ->
Gen [Tx]
genCommits :: HydraContext -> Tx -> Gen [Tx]
genCommits =
Gen UTxO -> HydraContext -> Tx -> Gen [Tx]
genCommits' Gen UTxO
genCommit
genCommits' ::
Gen UTxO ->
HydraContext ->
Tx ->
Gen [Tx]
genCommits' :: Gen UTxO -> HydraContext -> Tx -> Gen [Tx]
genCommits' Gen UTxO
genUTxO HydraContext
ctx Tx
txInit = do
[UTxO]
commitUTxOs <- [Party] -> (Party -> Gen UTxO) -> Gen [UTxO]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (HydraContext -> [Party]
ctxParties HydraContext
ctx) ((Party -> Gen UTxO) -> Gen [UTxO])
-> (Party -> Gen UTxO) -> Gen [UTxO]
forall a b. (a -> b) -> a -> b
$ Gen UTxO -> Party -> Gen UTxO
forall a b. a -> b -> a
const Gen UTxO
genUTxO
let scaledCommitUTxOs :: [UTxO]
scaledCommitUTxOs = [UTxO] -> [UTxO]
forall {f :: * -> *} {ctx} {era}.
(Foldable f, Monoid (f (TxOut ctx era)), Functor f,
IsMaryEraOnwards era, IsShelleyBasedEra era) =>
[f (TxOut ctx era)] -> [f (TxOut ctx era)]
scaleCommitUTxOs [UTxO]
commitUTxOs
[ChainContext]
allChainContexts <- HydraContext -> Gen [ChainContext]
deriveChainContexts HydraContext
ctx
[(ChainContext, UTxO)]
-> ((ChainContext, UTxO) -> Gen Tx) -> Gen [Tx]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([ChainContext] -> [UTxO] -> [(ChainContext, UTxO)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ChainContext]
allChainContexts [UTxO]
scaledCommitUTxOs) (((ChainContext, UTxO) -> Gen Tx) -> Gen [Tx])
-> ((ChainContext, UTxO) -> Gen Tx) -> Gen [Tx]
forall a b. (a -> b) -> a -> b
$ \(ChainContext
cctx, UTxO
toCommit) -> do
let stInitial :: InitialState
stInitial@InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit
Tx -> Gen Tx
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Gen Tx) -> Tx -> Gen Tx
forall a b. (a -> b) -> a -> b
$ HasCallStack => ChainContext -> HeadId -> UTxO -> UTxO -> Tx
ChainContext -> HeadId -> UTxO -> UTxO -> Tx
unsafeCommit ChainContext
cctx HeadId
headId (InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial) UTxO
toCommit
where
scaleCommitUTxOs :: [f (TxOut ctx era)] -> [f (TxOut ctx era)]
scaleCommitUTxOs [f (TxOut ctx era)]
commitUTxOs =
let numberOfUTxOs :: Int
numberOfUTxOs = f (TxOut ctx era) -> Int
forall a. f a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (f (TxOut ctx era) -> Int) -> f (TxOut ctx era) -> Int
forall a b. (a -> b) -> a -> b
$ [f (TxOut ctx era)] -> f (TxOut ctx era)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [f (TxOut ctx era)]
commitUTxOs
in (f (TxOut ctx era) -> f (TxOut ctx era))
-> [f (TxOut ctx era)] -> [f (TxOut ctx era)]
forall a b. (a -> b) -> [a] -> [b]
map ((TxOut ctx era -> TxOut ctx era)
-> f (TxOut ctx era) -> f (TxOut ctx era)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Value -> Value) -> TxOut ctx era -> TxOut ctx era
forall era ctx.
(IsMaryEraOnwards era, IsShelleyBasedEra era) =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Int -> Value -> Value
forall {a}. Integral a => a -> Value -> Value
scaleQuantitiesDownBy Int
numberOfUTxOs))) [f (TxOut ctx era)]
commitUTxOs
scaleQuantitiesDownBy :: a -> Value -> Value
scaleQuantitiesDownBy a
x =
[(AssetId, Quantity)] -> Value
valueFromList ([(AssetId, Quantity)] -> Value)
-> (Value -> [(AssetId, Quantity)]) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AssetId, Quantity) -> (AssetId, Quantity))
-> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
forall a b. (a -> b) -> [a] -> [b]
map (\(AssetId
an, Quantity Integer
q) -> (AssetId
an, Integer -> Quantity
Quantity (Integer -> Quantity) -> Integer -> Quantity
forall a b. (a -> b) -> a -> b
$ Integer
q Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x)) ([(AssetId, Quantity)] -> [(AssetId, Quantity)])
-> (Value -> [(AssetId, Quantity)])
-> Value
-> [(AssetId, Quantity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
valueToList
genCommitFor :: VerificationKey PaymentKey -> Gen UTxO
genCommitFor :: VerificationKey PaymentKey -> Gen UTxO
genCommitFor VerificationKey PaymentKey
vkey =
[(Int, Gen UTxO)] -> Gen UTxO
forall a. [(Int, Gen a)] -> Gen a
frequency
[ (Int
1, UTxO -> Gen UTxO
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
forall a. Monoid a => a
mempty)
, (Int
10, VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor VerificationKey PaymentKey
vkey)
]
genCommit :: Gen UTxO
genCommit :: Gen UTxO
genCommit =
[(Int, Gen UTxO)] -> Gen UTxO
forall a. [(Int, Gen a)] -> Gen a
frequency
[ (Int
1, UTxO -> Gen UTxO
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
forall a. Monoid a => a
mempty)
, (Int
10, Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Gen UTxO) -> Gen UTxO
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor)
]
genCollectComTx :: Gen (ChainContext, [UTxO], InitialState, Tx)
genCollectComTx :: Gen (ChainContext, [UTxO], InitialState, Tx)
genCollectComTx = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
maximumNumberOfParties
Tx
txInit <- HydraContext -> Gen Tx
genInitTx HydraContext
ctx
[Tx]
commits <- HydraContext -> Tx -> Gen [Tx]
genCommits HydraContext
ctx Tx
txInit
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
let ([UTxO]
committedUTxO, InitialState
stInitialized) = HasCallStack =>
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
unsafeObserveInitAndCommits ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit [Tx]
commits
let InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = InitialState
stInitialized
let utxoToCollect :: UTxO
utxoToCollect = [UTxO] -> UTxO
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [UTxO]
committedUTxO
let spendableUTxO :: UTxO
spendableUTxO = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitialized
(ChainContext, [UTxO], InitialState, Tx)
-> Gen (ChainContext, [UTxO], InitialState, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, [UTxO]
committedUTxO, InitialState
stInitialized, ChainContext -> HeadId -> HeadParameters -> UTxO -> UTxO -> Tx
unsafeCollect ChainContext
cctx HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) UTxO
utxoToCollect UTxO
spendableUTxO)
genCloseTx :: Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
genCloseTx :: Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
genCloseTx Int
numParties = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
numParties
(UTxO
u0, stOpen :: OpenState
stOpen@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
ConfirmedSnapshot Tx
snapshot <- HeadId
-> SnapshotNumber
-> UTxOType Tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotNumber
-> UTxOType tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotNumber
0 UTxO
UTxOType Tx
u0 (HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys HydraContext
ctx)
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
let cp :: ContestationPeriod
cp = HydraContext -> ContestationPeriod
ctxContestationPeriod HydraContext
ctx
(SlotNo
startSlot, PointInTime
pointInTime) <- ContestationPeriod -> Gen (SlotNo, PointInTime)
genValidityBoundsFromContestationPeriod ContestationPeriod
cp
let utxo :: UTxO
utxo = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
stOpen
(ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
-> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainContext
cctx, OpenState
stOpen, HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
utxo HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
snapshot SlotNo
startSlot PointInTime
pointInTime, ConfirmedSnapshot Tx
snapshot)
genContestTx :: Gen (HydraContext, PointInTime, ClosedState, Tx)
genContestTx :: Gen (HydraContext, PointInTime, ClosedState, Tx)
genContestTx = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContextFor Int
maximumNumberOfParties
(UTxO
u0, stOpen :: OpenState
stOpen@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
ConfirmedSnapshot Tx
confirmed <- HeadId
-> SnapshotNumber
-> UTxOType Tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotNumber
-> UTxOType tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId SnapshotNumber
0 UTxO
UTxOType Tx
u0 []
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
let cp :: ContestationPeriod
cp = HydraContext -> ContestationPeriod
ctxContestationPeriod HydraContext
ctx
(SlotNo
startSlot, PointInTime
closePointInTime) <- ContestationPeriod -> Gen (SlotNo, PointInTime)
genValidityBoundsFromContestationPeriod ContestationPeriod
cp
let openUTxO :: UTxO
openUTxO = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
stOpen
let txClose :: Tx
txClose = HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
openUTxO HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
confirmed SlotNo
startSlot PointInTime
closePointInTime
let stClosed :: ClosedState
stClosed = (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a, b) -> b
snd ((OnChainTx Tx, ClosedState) -> ClosedState)
-> (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a -> b) -> a -> b
$ Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState))
-> Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState)
forall a b. (a -> b) -> a -> b
$ OpenState -> Tx -> Maybe (OnChainTx Tx, ClosedState)
observeClose OpenState
stOpen Tx
txClose
let utxo :: UTxO
utxo = ClosedState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ClosedState
stClosed
UTxO
someUtxo <- Gen UTxO
forall a. Arbitrary a => Gen a
arbitrary
ConfirmedSnapshot Tx
contestSnapshot <- HeadId
-> SnapshotNumber
-> UTxOType Tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot Tx)
forall tx.
IsTx tx =>
HeadId
-> SnapshotNumber
-> UTxOType tx
-> [SigningKey HydraKey]
-> Gen (ConfirmedSnapshot tx)
genConfirmedSnapshot HeadId
headId (SnapshotNumber -> SnapshotNumber
forall a. Enum a => a -> a
succ (SnapshotNumber -> SnapshotNumber)
-> SnapshotNumber -> SnapshotNumber
forall a b. (a -> b) -> a -> b
$ Snapshot Tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number (Snapshot Tx -> SnapshotNumber) -> Snapshot Tx -> SnapshotNumber
forall a b. (a -> b) -> a -> b
$ ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. ConfirmedSnapshot tx -> Snapshot tx
getSnapshot ConfirmedSnapshot Tx
confirmed) UTxO
UTxOType Tx
someUtxo (HydraContext -> [SigningKey HydraKey]
ctxHydraSigningKeys HydraContext
ctx)
PointInTime
contestPointInTime <- UTCTime -> Gen PointInTime
genPointInTimeBefore (ClosedState -> UTCTime
getContestationDeadline ClosedState
stClosed)
(HydraContext, PointInTime, ClosedState, Tx)
-> Gen (HydraContext, PointInTime, ClosedState, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraContext
ctx, PointInTime
closePointInTime, ClosedState
stClosed, HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
unsafeContest ChainContext
cctx UTxO
utxo HeadId
headId ContestationPeriod
cp ConfirmedSnapshot Tx
contestSnapshot PointInTime
contestPointInTime)
genFanoutTx :: Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx :: Int -> Int -> Gen (HydraContext, ClosedState, Tx)
genFanoutTx Int
numParties Int
numOutputs = do
HydraContext
ctx <- Int -> Gen HydraContext
genHydraContext Int
numParties
UTxO
utxo <- Int -> Gen UTxO
genUTxOAdaOnlyOfSize Int
numOutputs
(SnapshotNumber
_, UTxO
toFanout, stClosed :: ClosedState
stClosed@ClosedState{TxIn
$sel:seedTxIn:ClosedState :: ClosedState -> TxIn
seedTxIn :: TxIn
seedTxIn}) <- HydraContext -> UTxO -> Gen (SnapshotNumber, UTxO, ClosedState)
genStClosed HydraContext
ctx UTxO
utxo
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
let deadlineSlotNo :: SlotNo
deadlineSlotNo = SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength (ClosedState -> UTCTime
getContestationDeadline ClosedState
stClosed)
spendableUTxO :: UTxO
spendableUTxO = ClosedState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ClosedState
stClosed
(HydraContext, ClosedState, Tx)
-> Gen (HydraContext, ClosedState, Tx)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HydraContext
ctx, ClosedState
stClosed, HasCallStack =>
ChainContext -> UTxO -> TxIn -> UTxO -> SlotNo -> Tx
ChainContext -> UTxO -> TxIn -> UTxO -> SlotNo -> Tx
unsafeFanout ChainContext
cctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
toFanout SlotNo
deadlineSlotNo)
getContestationDeadline :: ClosedState -> UTCTime
getContestationDeadline :: ClosedState -> UTCTime
getContestationDeadline
ClosedState{$sel:closedThreadOutput:ClosedState :: ClosedState -> ClosedThreadOutput
closedThreadOutput = ClosedThreadOutput{POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: ClosedThreadOutput -> POSIXTime
closedContestationDeadline :: POSIXTime
closedContestationDeadline}} =
POSIXTime -> UTCTime
posixToUTCTime POSIXTime
closedContestationDeadline
genStOpen ::
HydraContext ->
Gen (UTxO, OpenState)
genStOpen :: HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx = do
Tx
txInit <- HydraContext -> Gen Tx
genInitTx HydraContext
ctx
[Tx]
commits <- HydraContext -> Tx -> Gen [Tx]
genCommits HydraContext
ctx Tx
txInit
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
let ([UTxO]
committed, InitialState
stInitial) = HasCallStack =>
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
unsafeObserveInitAndCommits ChainContext
cctx (HydraContext -> [VerificationKey PaymentKey]
ctxVerificationKeys HydraContext
ctx) Tx
txInit [Tx]
commits
let InitialState{HeadId
$sel:headId:InitialState :: InitialState -> HeadId
headId :: HeadId
headId} = InitialState
stInitial
let utxoToCollect :: UTxO
utxoToCollect = [UTxO] -> UTxO
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [UTxO]
committed
let spendableUTxO :: UTxO
spendableUTxO = InitialState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO InitialState
stInitial
let txCollect :: Tx
txCollect = ChainContext -> HeadId -> HeadParameters -> UTxO -> UTxO -> Tx
unsafeCollect ChainContext
cctx HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) UTxO
utxoToCollect UTxO
spendableUTxO
(UTxO, OpenState) -> Gen (UTxO, OpenState)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([UTxO] -> UTxO
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [UTxO]
committed, (OnChainTx Tx, OpenState) -> OpenState
forall a b. (a, b) -> b
snd ((OnChainTx Tx, OpenState) -> OpenState)
-> (Maybe (OnChainTx Tx, OpenState) -> (OnChainTx Tx, OpenState))
-> Maybe (OnChainTx Tx, OpenState)
-> OpenState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (OnChainTx Tx, OpenState) -> (OnChainTx Tx, OpenState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, OpenState) -> OpenState)
-> Maybe (OnChainTx Tx, OpenState) -> OpenState
forall a b. (a -> b) -> a -> b
$ InitialState -> Tx -> Maybe (OnChainTx Tx, OpenState)
observeCollect InitialState
stInitial Tx
txCollect)
genStClosed ::
HydraContext ->
UTxO ->
Gen (SnapshotNumber, UTxO, ClosedState)
genStClosed :: HydraContext -> UTxO -> Gen (SnapshotNumber, UTxO, ClosedState)
genStClosed HydraContext
ctx UTxO
utxo = do
(UTxO
u0, stOpen :: OpenState
stOpen@OpenState{HeadId
$sel:headId:OpenState :: OpenState -> HeadId
headId :: HeadId
headId}) <- HydraContext -> Gen (UTxO, OpenState)
genStOpen HydraContext
ctx
ConfirmedSnapshot Tx
confirmed <- Gen (ConfirmedSnapshot Tx)
forall a. Arbitrary a => Gen a
arbitrary
let (SnapshotNumber
sn, ConfirmedSnapshot Tx
snapshot, UTxO
toFanout) = case ConfirmedSnapshot Tx
confirmed of
InitialSnapshot{} ->
( SnapshotNumber
0
, InitialSnapshot{HeadId
headId :: HeadId
$sel:headId:InitialSnapshot :: HeadId
headId, $sel:initialUTxO:InitialSnapshot :: UTxOType Tx
initialUTxO = UTxO
UTxOType Tx
u0}
, UTxO
u0
)
ConfirmedSnapshot{$sel:snapshot:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> Snapshot tx
snapshot = Snapshot Tx
snap, MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: forall tx. ConfirmedSnapshot tx -> MultiSignature (Snapshot tx)
signatures :: MultiSignature (Snapshot Tx)
signatures} ->
( Snapshot Tx -> SnapshotNumber
forall tx. Snapshot tx -> SnapshotNumber
number Snapshot Tx
snap
, ConfirmedSnapshot
{ $sel:snapshot:InitialSnapshot :: Snapshot Tx
snapshot = Snapshot Tx
snap{utxo = utxo}
, MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
signatures
}
, UTxO
utxo
)
ChainContext
cctx <- HydraContext -> Gen ChainContext
pickChainContext HydraContext
ctx
let cp :: ContestationPeriod
cp = HydraContext -> ContestationPeriod
ctxContestationPeriod HydraContext
ctx
(SlotNo
startSlot, PointInTime
pointInTime) <- ContestationPeriod -> Gen (SlotNo, PointInTime)
genValidityBoundsFromContestationPeriod ContestationPeriod
cp
let utxo' :: UTxO
utxo' = OpenState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO OpenState
stOpen
let txClose :: Tx
txClose = HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
cctx UTxO
utxo' HeadId
headId (HydraContext -> HeadParameters
ctxHeadParameters HydraContext
ctx) ConfirmedSnapshot Tx
snapshot SlotNo
startSlot PointInTime
pointInTime
(SnapshotNumber, UTxO, ClosedState)
-> Gen (SnapshotNumber, UTxO, ClosedState)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotNumber
sn, UTxO
toFanout, (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a, b) -> b
snd ((OnChainTx Tx, ClosedState) -> ClosedState)
-> (Maybe (OnChainTx Tx, ClosedState)
-> (OnChainTx Tx, ClosedState))
-> Maybe (OnChainTx Tx, ClosedState)
-> ClosedState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (OnChainTx Tx, ClosedState) -> (OnChainTx Tx, ClosedState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, ClosedState) -> ClosedState)
-> Maybe (OnChainTx Tx, ClosedState) -> ClosedState
forall a b. (a -> b) -> a -> b
$ OpenState -> Tx -> Maybe (OnChainTx Tx, ClosedState)
observeClose OpenState
stOpen Tx
txClose)
unsafeCommit ::
HasCallStack =>
ChainContext ->
HeadId ->
UTxO ->
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 ->
TxIn ->
UTxO ->
UTxO ->
Tx
unsafeAbort :: HasCallStack => ChainContext -> TxIn -> UTxO -> UTxO -> Tx
unsafeAbort ChainContext
ctx TxIn
seedTxIn UTxO
spendableUTxO UTxO
committedUTxO =
(AbortTxError -> Tx) -> (Tx -> Tx) -> Either AbortTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (AbortTxError -> Text) -> AbortTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbortTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either AbortTxError Tx -> Tx) -> Either AbortTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext -> TxIn -> UTxO -> UTxO -> Either AbortTxError Tx
abort ChainContext
ctx TxIn
seedTxIn UTxO
spendableUTxO UTxO
committedUTxO
unsafeClose ::
HasCallStack =>
ChainContext ->
UTxO ->
HeadId ->
HeadParameters ->
ConfirmedSnapshot Tx ->
SlotNo ->
PointInTime ->
Tx
unsafeClose :: HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Tx
unsafeClose ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo PointInTime
pointInTime =
(CloseTxError -> Tx) -> (Tx -> Tx) -> Either CloseTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (CloseTxError -> Text) -> CloseTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CloseTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either CloseTxError Tx -> Tx) -> Either CloseTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
startSlotNo PointInTime
pointInTime
unsafeCollect ::
ChainContext ->
HeadId ->
HeadParameters ->
UTxO ->
UTxO ->
Tx
unsafeCollect :: ChainContext -> HeadId -> HeadParameters -> UTxO -> UTxO -> Tx
unsafeCollect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
utxoToCollect UTxO
spendableUTxO =
(CollectTxError -> Tx)
-> (Tx -> Tx) -> Either CollectTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (CollectTxError -> Text) -> CollectTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CollectTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either CollectTxError Tx -> Tx) -> Either CollectTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> HeadId
-> HeadParameters
-> UTxO
-> UTxO
-> Either CollectTxError Tx
collect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
utxoToCollect UTxO
spendableUTxO
unsafeContest ::
HasCallStack =>
ChainContext ->
UTxO ->
HeadId ->
ContestationPeriod ->
ConfirmedSnapshot Tx ->
PointInTime ->
Tx
unsafeContest :: HasCallStack =>
ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Tx
unsafeContest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot PointInTime
pointInTime =
(ContestTxError -> Tx)
-> (Tx -> Tx) -> Either ContestTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (ContestTxError -> Text) -> ContestTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContestTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either ContestTxError Tx -> Tx) -> Either ContestTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot PointInTime
pointInTime
unsafeFanout ::
HasCallStack =>
ChainContext ->
UTxO ->
TxIn ->
UTxO ->
SlotNo ->
Tx
unsafeFanout :: HasCallStack =>
ChainContext -> UTxO -> TxIn -> UTxO -> SlotNo -> Tx
unsafeFanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo SlotNo
deadlineSlotNo =
(FanoutTxError -> Tx)
-> (Tx -> Tx) -> Either FanoutTxError Tx -> Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Tx
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Tx) -> (FanoutTxError -> Text) -> FanoutTxError -> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FanoutTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show) Tx -> Tx
forall a. a -> a
id (Either FanoutTxError Tx -> Tx) -> Either FanoutTxError Tx -> Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO -> TxIn -> UTxO -> SlotNo -> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
spendableUTxO TxIn
seedTxIn UTxO
utxo SlotNo
deadlineSlotNo
unsafeObserveInit ::
HasCallStack =>
ChainContext ->
[VerificationKey PaymentKey] ->
Tx ->
InitialState
unsafeObserveInit :: HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
cctx [VerificationKey PaymentKey]
txInit Tx
allVerificationKeys =
case ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> Either NotAnInitReason (OnChainTx Tx, InitialState)
observeInit ChainContext
cctx [VerificationKey PaymentKey]
txInit Tx
allVerificationKeys of
Left NotAnInitReason
err -> Text -> InitialState
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> InitialState) -> Text -> InitialState
forall a b. (a -> b) -> a -> b
$ Text
"Did not observe an init tx: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NotAnInitReason -> Text
forall b a. (Show a, IsString b) => a -> b
show NotAnInitReason
err
Right (OnChainTx Tx, InitialState)
st -> (OnChainTx Tx, InitialState) -> InitialState
forall a b. (a, b) -> b
snd (OnChainTx Tx, InitialState)
st
unsafeObserveInitAndCommits ::
HasCallStack =>
ChainContext ->
[VerificationKey PaymentKey] ->
Tx ->
[Tx] ->
([UTxO], InitialState)
unsafeObserveInitAndCommits :: HasCallStack =>
ChainContext
-> [VerificationKey PaymentKey]
-> Tx
-> [Tx]
-> ([UTxO], InitialState)
unsafeObserveInitAndCommits ChainContext
ctx [VerificationKey PaymentKey]
allVerificationKeys Tx
txInit [Tx]
commits =
([UTxO]
utxo, InitialState
stInitial')
where
stInitial :: InitialState
stInitial = HasCallStack =>
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
ChainContext -> [VerificationKey PaymentKey] -> Tx -> InitialState
unsafeObserveInit ChainContext
ctx [VerificationKey PaymentKey]
allVerificationKeys Tx
txInit
([UTxO]
utxo, InitialState
stInitial') = (State InitialState [UTxO]
-> InitialState -> ([UTxO], InitialState))
-> InitialState
-> State InitialState [UTxO]
-> ([UTxO], InitialState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State InitialState [UTxO] -> InitialState -> ([UTxO], InitialState)
forall s a. State s a -> s -> (a, s)
runState InitialState
stInitial (State InitialState [UTxO] -> ([UTxO], InitialState))
-> State InitialState [UTxO] -> ([UTxO], InitialState)
forall a b. (a -> b) -> a -> b
$ do
[Tx]
-> (Tx -> StateT InitialState Identity UTxO)
-> State InitialState [UTxO]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Tx]
commits ((Tx -> StateT InitialState Identity UTxO)
-> State InitialState [UTxO])
-> (Tx -> StateT InitialState Identity UTxO)
-> State InitialState [UTxO]
forall a b. (a -> b) -> a -> b
$ \Tx
txCommit -> do
InitialState
st <- StateT InitialState Identity InitialState
forall s (m :: * -> *). MonadState s m => m s
get
let (OnChainTx Tx
event, InitialState
st') = Maybe (OnChainTx Tx, InitialState) -> (OnChainTx Tx, InitialState)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (OnChainTx Tx, InitialState)
-> (OnChainTx Tx, InitialState))
-> Maybe (OnChainTx Tx, InitialState)
-> (OnChainTx Tx, InitialState)
forall a b. (a -> b) -> a -> b
$ ChainContext
-> InitialState -> Tx -> Maybe (OnChainTx Tx, InitialState)
observeCommit ChainContext
ctx InitialState
st Tx
txCommit
InitialState -> StateT InitialState Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put InitialState
st'
UTxO -> StateT InitialState Identity UTxO
forall a. a -> StateT InitialState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> StateT InitialState Identity UTxO)
-> UTxO -> StateT InitialState Identity UTxO
forall a b. (a -> b) -> a -> b
$ case OnChainTx Tx
event of
OnCommitTx{UTxOType Tx
$sel:committed:OnInitTx :: forall tx. OnChainTx tx -> UTxOType tx
committed :: UTxOType Tx
committed} -> UTxO
UTxOType Tx
committed
OnChainTx Tx
_ -> UTxO
forall a. Monoid a => a
mempty