{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hydra.Chain where
import Hydra.Prelude
import Data.List (nub)
import Data.List.NonEmpty ((<|))
import Hydra.Cardano.Api (
Address,
ByronAddr,
Coin (..),
CtxUTxO,
Tx,
TxOut,
UTxO',
WitCtxTxIn,
Witness,
)
import Hydra.ContestationPeriod (ContestationPeriod)
import Hydra.Environment (Environment (..))
import Hydra.HeadId (HeadId, HeadSeed)
import Hydra.Ledger (ChainSlot, IsTx, UTxOType)
import Hydra.OnChainId (OnChainId)
import Hydra.Party (Party)
import Hydra.Snapshot (ConfirmedSnapshot, SnapshotNumber)
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Instances.Time ()
maxMainnetLovelace :: Coin
maxMainnetLovelace :: Coin
maxMainnetLovelace = Integer -> Coin
Coin Integer
100_000_000
maximumNumberOfParties :: Int
maximumNumberOfParties :: Int
maximumNumberOfParties = Int
5
data HeadParameters = HeadParameters
{ HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
, HeadParameters -> [Party]
parties :: [Party]
}
deriving stock (HeadParameters -> HeadParameters -> Bool
(HeadParameters -> HeadParameters -> Bool)
-> (HeadParameters -> HeadParameters -> Bool) -> Eq HeadParameters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeadParameters -> HeadParameters -> Bool
== :: HeadParameters -> HeadParameters -> Bool
$c/= :: HeadParameters -> HeadParameters -> Bool
/= :: HeadParameters -> HeadParameters -> Bool
Eq, Int -> HeadParameters -> ShowS
[HeadParameters] -> ShowS
HeadParameters -> String
(Int -> HeadParameters -> ShowS)
-> (HeadParameters -> String)
-> ([HeadParameters] -> ShowS)
-> Show HeadParameters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeadParameters -> ShowS
showsPrec :: Int -> HeadParameters -> ShowS
$cshow :: HeadParameters -> String
show :: HeadParameters -> String
$cshowList :: [HeadParameters] -> ShowS
showList :: [HeadParameters] -> ShowS
Show, (forall x. HeadParameters -> Rep HeadParameters x)
-> (forall x. Rep HeadParameters x -> HeadParameters)
-> Generic HeadParameters
forall x. Rep HeadParameters x -> HeadParameters
forall x. HeadParameters -> Rep HeadParameters x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeadParameters -> Rep HeadParameters x
from :: forall x. HeadParameters -> Rep HeadParameters x
$cto :: forall x. Rep HeadParameters x -> HeadParameters
to :: forall x. Rep HeadParameters x -> HeadParameters
Generic)
deriving anyclass ([HeadParameters] -> Value
[HeadParameters] -> Encoding
HeadParameters -> Bool
HeadParameters -> Value
HeadParameters -> Encoding
(HeadParameters -> Value)
-> (HeadParameters -> Encoding)
-> ([HeadParameters] -> Value)
-> ([HeadParameters] -> Encoding)
-> (HeadParameters -> Bool)
-> ToJSON HeadParameters
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HeadParameters -> Value
toJSON :: HeadParameters -> Value
$ctoEncoding :: HeadParameters -> Encoding
toEncoding :: HeadParameters -> Encoding
$ctoJSONList :: [HeadParameters] -> Value
toJSONList :: [HeadParameters] -> Value
$ctoEncodingList :: [HeadParameters] -> Encoding
toEncodingList :: [HeadParameters] -> Encoding
$comitField :: HeadParameters -> Bool
omitField :: HeadParameters -> Bool
ToJSON, Maybe HeadParameters
Value -> Parser [HeadParameters]
Value -> Parser HeadParameters
(Value -> Parser HeadParameters)
-> (Value -> Parser [HeadParameters])
-> Maybe HeadParameters
-> FromJSON HeadParameters
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser HeadParameters
parseJSON :: Value -> Parser HeadParameters
$cparseJSONList :: Value -> Parser [HeadParameters]
parseJSONList :: Value -> Parser [HeadParameters]
$comittedField :: Maybe HeadParameters
omittedField :: Maybe HeadParameters
FromJSON)
instance Arbitrary HeadParameters where
arbitrary :: Gen HeadParameters
arbitrary = HeadParameters -> HeadParameters
dedupParties (HeadParameters -> HeadParameters)
-> Gen HeadParameters -> Gen HeadParameters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadParameters
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
where
dedupParties :: HeadParameters -> HeadParameters
dedupParties HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties} =
HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, $sel:parties:HeadParameters :: [Party]
parties = [Party] -> [Party]
forall a. Eq a => [a] -> [a]
nub [Party]
parties}
mkHeadParameters :: Environment -> HeadParameters
mkHeadParameters :: Environment -> HeadParameters
mkHeadParameters Environment{Party
party :: Party
$sel:party:Environment :: Environment -> Party
party, [Party]
otherParties :: [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod} =
HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, $sel:parties:HeadParameters :: [Party]
parties = Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties}
data PostChainTx tx
= InitTx {forall tx. PostChainTx tx -> [OnChainId]
participants :: [OnChainId], forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters}
| AbortTx {forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx, forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed}
| CollectComTx {utxo :: UTxOType tx, forall tx. PostChainTx tx -> HeadId
headId :: HeadId, headParameters :: HeadParameters}
| CloseTx {headId :: HeadId, headParameters :: HeadParameters, forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx}
| ContestTx {headId :: HeadId, headParameters :: HeadParameters, confirmedSnapshot :: ConfirmedSnapshot tx}
| FanoutTx {utxo :: UTxOType tx, headSeed :: HeadSeed, forall tx. PostChainTx tx -> UTCTime
contestationDeadline :: UTCTime}
deriving stock ((forall x. PostChainTx tx -> Rep (PostChainTx tx) x)
-> (forall x. Rep (PostChainTx tx) x -> PostChainTx tx)
-> Generic (PostChainTx tx)
forall x. Rep (PostChainTx tx) x -> PostChainTx tx
forall x. PostChainTx tx -> Rep (PostChainTx tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (PostChainTx tx) x -> PostChainTx tx
forall tx x. PostChainTx tx -> Rep (PostChainTx tx) x
$cfrom :: forall tx x. PostChainTx tx -> Rep (PostChainTx tx) x
from :: forall x. PostChainTx tx -> Rep (PostChainTx tx) x
$cto :: forall tx x. Rep (PostChainTx tx) x -> PostChainTx tx
to :: forall x. Rep (PostChainTx tx) x -> PostChainTx tx
Generic)
deriving stock instance IsTx tx => Eq (PostChainTx tx)
deriving stock instance IsTx tx => Show (PostChainTx tx)
deriving anyclass instance IsTx tx => ToJSON (PostChainTx tx)
deriving anyclass instance IsTx tx => FromJSON (PostChainTx tx)
instance IsTx tx => Arbitrary (PostChainTx tx) where
arbitrary :: Gen (PostChainTx tx)
arbitrary = Gen (PostChainTx tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
shrink :: PostChainTx tx -> [PostChainTx tx]
shrink = \case
InitTx{[OnChainId]
$sel:participants:InitTx :: forall tx. PostChainTx tx -> [OnChainId]
participants :: [OnChainId]
participants, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters} -> [OnChainId] -> HeadParameters -> PostChainTx tx
forall tx. [OnChainId] -> HeadParameters -> PostChainTx tx
InitTx ([OnChainId] -> HeadParameters -> PostChainTx tx)
-> [[OnChainId]] -> [HeadParameters -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OnChainId] -> [[OnChainId]]
forall a. Arbitrary a => a -> [a]
shrink [OnChainId]
participants [HeadParameters -> PostChainTx tx]
-> [HeadParameters] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters
AbortTx{UTxOType tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
utxo, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed} -> UTxOType tx -> HeadSeed -> PostChainTx tx
forall tx. UTxOType tx -> HeadSeed -> PostChainTx tx
AbortTx (UTxOType tx -> HeadSeed -> PostChainTx tx)
-> [UTxOType tx] -> [HeadSeed -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
utxo [HeadSeed -> PostChainTx tx] -> [HeadSeed] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadSeed -> [HeadSeed]
forall a. Arbitrary a => a -> [a]
shrink HeadSeed
headSeed
CollectComTx{UTxOType tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
utxo, HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters} -> UTxOType tx -> HeadId -> HeadParameters -> PostChainTx tx
forall tx.
UTxOType tx -> HeadId -> HeadParameters -> PostChainTx tx
CollectComTx (UTxOType tx -> HeadId -> HeadParameters -> PostChainTx tx)
-> [UTxOType tx] -> [HeadId -> HeadParameters -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
utxo [HeadId -> HeadParameters -> PostChainTx tx]
-> [HeadId] -> [HeadParameters -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [HeadParameters -> PostChainTx tx]
-> [HeadParameters] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters
CloseTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} -> HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
forall tx.
HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
CloseTx (HeadId
-> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx)
-> [HeadId]
-> [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [HeadParameters] -> [ConfirmedSnapshot tx -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters [ConfirmedSnapshot tx -> PostChainTx tx]
-> [ConfirmedSnapshot tx] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConfirmedSnapshot tx -> [ConfirmedSnapshot tx]
forall a. Arbitrary a => a -> [a]
shrink ConfirmedSnapshot tx
confirmedSnapshot
ContestTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} -> HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
forall tx.
HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
ContestTx (HeadId
-> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx)
-> [HeadId]
-> [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [HeadParameters] -> [ConfirmedSnapshot tx -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters [ConfirmedSnapshot tx -> PostChainTx tx]
-> [ConfirmedSnapshot tx] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConfirmedSnapshot tx -> [ConfirmedSnapshot tx]
forall a. Arbitrary a => a -> [a]
shrink ConfirmedSnapshot tx
confirmedSnapshot
FanoutTx{UTxOType tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
utxo, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
$sel:contestationDeadline:InitTx :: forall tx. PostChainTx tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline} -> UTxOType tx -> HeadSeed -> UTCTime -> PostChainTx tx
forall tx. UTxOType tx -> HeadSeed -> UTCTime -> PostChainTx tx
FanoutTx (UTxOType tx -> HeadSeed -> UTCTime -> PostChainTx tx)
-> [UTxOType tx] -> [HeadSeed -> UTCTime -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
utxo [HeadSeed -> UTCTime -> PostChainTx tx]
-> [HeadSeed] -> [UTCTime -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadSeed -> [HeadSeed]
forall a. Arbitrary a => a -> [a]
shrink HeadSeed
headSeed [UTCTime -> PostChainTx tx] -> [UTCTime] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime -> [UTCTime]
forall a. Arbitrary a => a -> [a]
shrink UTCTime
contestationDeadline
data OnChainTx tx
= OnInitTx
{ forall tx. OnChainTx tx -> HeadId
headId :: HeadId
, forall tx. OnChainTx tx -> HeadSeed
headSeed :: HeadSeed
, forall tx. OnChainTx tx -> HeadParameters
headParameters :: HeadParameters
, forall tx. OnChainTx tx -> [OnChainId]
participants :: [OnChainId]
}
| OnCommitTx
{ headId :: HeadId
, forall tx. OnChainTx tx -> Party
party :: Party
, forall tx. OnChainTx tx -> UTxOType tx
committed :: UTxOType tx
}
| OnAbortTx {headId :: HeadId}
| OnCollectComTx {headId :: HeadId}
| OnCloseTx
{ headId :: HeadId
, forall tx. OnChainTx tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
, forall tx. OnChainTx tx -> UTCTime
contestationDeadline :: UTCTime
}
| OnContestTx
{ headId :: HeadId
, snapshotNumber :: SnapshotNumber
, contestationDeadline :: UTCTime
}
| OnFanoutTx {headId :: HeadId}
deriving stock ((forall x. OnChainTx tx -> Rep (OnChainTx tx) x)
-> (forall x. Rep (OnChainTx tx) x -> OnChainTx tx)
-> Generic (OnChainTx tx)
forall x. Rep (OnChainTx tx) x -> OnChainTx tx
forall x. OnChainTx tx -> Rep (OnChainTx tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (OnChainTx tx) x -> OnChainTx tx
forall tx x. OnChainTx tx -> Rep (OnChainTx tx) x
$cfrom :: forall tx x. OnChainTx tx -> Rep (OnChainTx tx) x
from :: forall x. OnChainTx tx -> Rep (OnChainTx tx) x
$cto :: forall tx x. Rep (OnChainTx tx) x -> OnChainTx tx
to :: forall x. Rep (OnChainTx tx) x -> OnChainTx tx
Generic)
deriving stock instance IsTx tx => Eq (OnChainTx tx)
deriving stock instance IsTx tx => Show (OnChainTx tx)
deriving anyclass instance IsTx tx => ToJSON (OnChainTx tx)
deriving anyclass instance IsTx tx => FromJSON (OnChainTx tx)
instance (Arbitrary tx, Arbitrary (UTxOType tx)) => Arbitrary (OnChainTx tx) where
arbitrary :: Gen (OnChainTx tx)
arbitrary = Gen (OnChainTx tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
data PostTxError tx
= NoSeedInput
| InvalidSeed {forall tx. PostTxError tx -> HeadSeed
headSeed :: HeadSeed}
| InvalidHeadId {forall tx. PostTxError tx -> HeadId
headId :: HeadId}
| CannotFindOwnInitial {forall tx. PostTxError tx -> UTxOType tx
knownUTxO :: UTxOType tx}
|
UnsupportedLegacyOutput {forall tx. PostTxError tx -> Address ByronAddr
byronAddress :: Address ByronAddr}
|
CannotCommitReferenceScript
| InvalidStateToPost {forall tx. PostTxError tx -> PostChainTx tx
txTried :: PostChainTx tx, forall tx. PostTxError tx -> ChainStateType tx
chainState :: ChainStateType tx}
| NotEnoughFuel
| NoFuelUTXOFound
|
ScriptFailedInWallet {forall tx. PostTxError tx -> Text
redeemerPtr :: Text, forall tx. PostTxError tx -> Text
failureReason :: Text}
|
InternalWalletError {forall tx. PostTxError tx -> UTxOType tx
headUTxO :: UTxOType tx, forall tx. PostTxError tx -> Text
reason :: Text, forall tx. PostTxError tx -> tx
tx :: tx}
|
FailedToPostTx {failureReason :: Text}
|
PlutusValidationFailed {forall tx. PostTxError tx -> Text
plutusFailure :: Text, forall tx. PostTxError tx -> Text
plutusDebugInfo :: Text}
|
CommittedTooMuchADAForMainnet {forall tx. PostTxError tx -> Coin
userCommittedLovelace :: Coin, forall tx. PostTxError tx -> Coin
mainnetLimitLovelace :: Coin}
|
FailedToDraftTxNotInitializing
|
SpendingNodeUtxoForbidden
| FailedToConstructAbortTx
| FailedToConstructCloseTx
| FailedToConstructContestTx
| FailedToConstructCollectTx
| FailedToConstructFanoutTx
deriving stock ((forall x. PostTxError tx -> Rep (PostTxError tx) x)
-> (forall x. Rep (PostTxError tx) x -> PostTxError tx)
-> Generic (PostTxError tx)
forall x. Rep (PostTxError tx) x -> PostTxError tx
forall x. PostTxError tx -> Rep (PostTxError tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (PostTxError tx) x -> PostTxError tx
forall tx x. PostTxError tx -> Rep (PostTxError tx) x
$cfrom :: forall tx x. PostTxError tx -> Rep (PostTxError tx) x
from :: forall x. PostTxError tx -> Rep (PostTxError tx) x
$cto :: forall tx x. Rep (PostTxError tx) x -> PostTxError tx
to :: forall x. Rep (PostTxError tx) x -> PostTxError tx
Generic)
deriving stock instance IsChainState tx => Eq (PostTxError tx)
deriving stock instance IsChainState tx => Show (PostTxError tx)
deriving anyclass instance IsChainState tx => ToJSON (PostTxError tx)
deriving anyclass instance IsChainState tx => FromJSON (PostTxError tx)
instance IsChainState tx => Exception (PostTxError tx)
instance (IsTx tx, Arbitrary (ChainStateType tx)) => Arbitrary (PostTxError tx) where
arbitrary :: Gen (PostTxError tx)
arbitrary = Gen (PostTxError tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
data ChainStateHistory tx = UnsafeChainStateHistory
{ forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
, forall tx. ChainStateHistory tx -> ChainStateType tx
defaultChainState :: ChainStateType tx
}
deriving stock ((forall x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x)
-> (forall x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx)
-> Generic (ChainStateHistory tx)
forall x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
forall x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
forall tx x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
$cfrom :: forall tx x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
from :: forall x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
$cto :: forall tx x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
to :: forall x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
Generic)
currentState :: ChainStateHistory tx -> ChainStateType tx
currentState :: forall tx. ChainStateHistory tx -> ChainStateType tx
currentState UnsafeChainStateHistory{NonEmpty (ChainStateType tx)
$sel:history:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
history} = NonEmpty (ChainStateType tx) -> ChainStateType tx
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty (ChainStateType tx)
history
pushNewState :: ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState :: forall tx.
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
cs h :: ChainStateHistory tx
h@UnsafeChainStateHistory{NonEmpty (ChainStateType tx)
$sel:history:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
history} = ChainStateHistory tx
h{history = cs <| history}
initHistory :: ChainStateType tx -> ChainStateHistory tx
initHistory :: forall tx. ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType tx
cs = UnsafeChainStateHistory{$sel:history:UnsafeChainStateHistory :: NonEmpty (ChainStateType tx)
history = ChainStateType tx
cs ChainStateType tx
-> [ChainStateType tx] -> NonEmpty (ChainStateType tx)
forall a. a -> [a] -> NonEmpty a
:| [], $sel:defaultChainState:UnsafeChainStateHistory :: ChainStateType tx
defaultChainState = ChainStateType tx
cs}
rollbackHistory :: IsChainState tx => ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
rollbackHistory :: forall tx.
IsChainState tx =>
ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
rollbackHistory ChainSlot
rollbackChainSlot h :: ChainStateHistory tx
h@UnsafeChainStateHistory{NonEmpty (ChainStateType tx)
$sel:history:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
history, ChainStateType tx
$sel:defaultChainState:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> ChainStateType tx
defaultChainState :: ChainStateType tx
defaultChainState} =
ChainStateHistory tx
h{history = fromMaybe (defaultChainState :| []) (nonEmpty rolledBack)}
where
rolledBack :: [ChainStateType tx]
rolledBack =
(ChainStateType tx -> Bool)
-> [ChainStateType tx] -> [ChainStateType tx]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile
(\ChainStateType tx
cs -> ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
cs ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
> ChainSlot
rollbackChainSlot)
(NonEmpty (ChainStateType tx) -> [ChainStateType tx]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (ChainStateType tx)
history)
deriving stock instance Eq (ChainStateType tx) => Eq (ChainStateHistory tx)
deriving stock instance Show (ChainStateType tx) => Show (ChainStateHistory tx)
deriving anyclass instance ToJSON (ChainStateType tx) => ToJSON (ChainStateHistory tx)
deriving anyclass instance FromJSON (ChainStateType tx) => FromJSON (ChainStateHistory tx)
instance Arbitrary (ChainStateType tx) => Arbitrary (ChainStateHistory tx) where
arbitrary :: Gen (ChainStateHistory tx)
arbitrary = Gen (ChainStateHistory tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
class
( IsTx tx
, Eq (ChainStateType tx)
, Show (ChainStateType tx)
, Arbitrary (ChainStateType tx)
, FromJSON (ChainStateType tx)
, ToJSON (ChainStateType tx)
) =>
IsChainState tx
where
type ChainStateType tx = c | c -> tx
chainStateSlot :: ChainStateType tx -> ChainSlot
data Chain tx m = Chain
{ forall tx (m :: * -> *).
Chain tx m -> MonadThrow m => PostChainTx tx -> m ()
postTx :: MonadThrow m => PostChainTx tx -> m ()
, forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
HeadId
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> m (Either (PostTxError Tx) Tx)
draftCommitTx ::
MonadThrow m =>
HeadId ->
UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) ->
m (Either (PostTxError Tx) Tx)
, forall tx (m :: * -> *). Chain tx m -> MonadThrow m => Tx -> m ()
submitTx :: MonadThrow m => Tx -> m ()
}
data ChainEvent tx
=
Observation
{ forall tx. ChainEvent tx -> OnChainTx tx
observedTx :: OnChainTx tx
, forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
}
| Rollback
{ forall tx. ChainEvent tx -> ChainStateType tx
rolledBackChainState :: ChainStateType tx
}
|
Tick
{ forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
, forall tx. ChainEvent tx -> ChainSlot
chainSlot :: ChainSlot
}
|
PostTxError {forall tx. ChainEvent tx -> PostChainTx tx
postChainTx :: PostChainTx tx, forall tx. ChainEvent tx -> PostTxError tx
postTxError :: PostTxError tx}
deriving stock ((forall x. ChainEvent tx -> Rep (ChainEvent tx) x)
-> (forall x. Rep (ChainEvent tx) x -> ChainEvent tx)
-> Generic (ChainEvent tx)
forall x. Rep (ChainEvent tx) x -> ChainEvent tx
forall x. ChainEvent tx -> Rep (ChainEvent tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ChainEvent tx) x -> ChainEvent tx
forall tx x. ChainEvent tx -> Rep (ChainEvent tx) x
$cfrom :: forall tx x. ChainEvent tx -> Rep (ChainEvent tx) x
from :: forall x. ChainEvent tx -> Rep (ChainEvent tx) x
$cto :: forall tx x. Rep (ChainEvent tx) x -> ChainEvent tx
to :: forall x. Rep (ChainEvent tx) x -> ChainEvent tx
Generic)
deriving stock instance (IsTx tx, IsChainState tx) => Eq (ChainEvent tx)
deriving stock instance (IsTx tx, IsChainState tx) => Show (ChainEvent tx)
deriving anyclass instance (IsTx tx, IsChainState tx) => ToJSON (ChainEvent tx)
deriving anyclass instance (IsTx tx, IsChainState tx) => FromJSON (ChainEvent tx)
instance (IsTx tx, IsChainState tx) => Arbitrary (ChainEvent tx) where
arbitrary :: Gen (ChainEvent tx)
arbitrary = Gen (ChainEvent tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
type ChainCallback tx m = ChainEvent tx -> m ()
type ChainComponent tx m a = ChainCallback tx m -> (Chain tx m -> m a) -> m a