module Hydra.Chain.Direct.TxTraceSpec where
import Hydra.Prelude hiding (Any, State, label, show)
import Test.Hydra.Prelude
import Cardano.Api.UTxO (UTxO)
import Cardano.Api.UTxO qualified as UTxO
import Data.List ((\\))
import Data.Map.Strict qualified as Map
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Hydra.Cardano.Api (mkTxOutDatumInline)
import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
import Hydra.Chain.Direct.Contract.Mutation (addParticipationTokens)
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.ScriptRegistry (ScriptRegistry, genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.State (ChainContext (..), close, contest)
import Hydra.Chain.Direct.Tx (HeadObservation, headIdToCurrencySymbol, mkHeadId, mkHeadOutput, observeHeadTx)
import Hydra.Chain.Direct.Tx qualified as Tx
import Hydra.ContestationPeriod qualified as CP
import Hydra.Contract.HeadState qualified as Head
import Hydra.Crypto (aggregate, sign)
import Hydra.Ledger (hashUTxO)
import Hydra.Ledger.Cardano (Tx, adjustUTxO, genUTxOFor, genVerificationKey)
import Hydra.Ledger.Cardano.Evaluate (evaluateTx)
import Hydra.Party (partyToChain)
import Hydra.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber, number)
import PlutusTx.Builtins (toBuiltin)
import Test.Hydra.Fixture (genForParty)
import Test.Hydra.Fixture qualified as Fixture
import Test.QuickCheck (Property, Smart (..), checkCoverage, cover, elements, forAll, oneof, resize)
import Test.QuickCheck.Monadic (monadicIO)
import Test.QuickCheck.StateModel (
ActionWithPolarity (..),
Actions (..),
Any (..),
HasVariables (getAllVariables),
LookUp,
RunModel (..),
StateModel (..),
Step ((:=)),
Var,
VarContext,
mkVar,
runActions,
)
import Text.Pretty.Simple (pShowNoColor)
import Text.Show (Show (..))
spec :: Spec
spec :: Spec
spec = do
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"generates interesting transaction traces" Property
prop_traces
String -> (Actions Model -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"all valid transactions" Actions Model -> Property
prop_runActions
prop_traces :: Property
prop_traces :: Property
prop_traces =
Gen (Actions Model) -> (Actions Model -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen (Actions Model)
forall a. Arbitrary a => Gen a
arbitrary :: Gen (Actions Model)) ((Actions Model -> Property) -> Property)
-> (Actions Model -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(Actions_ [String]
_ (Smart Int
_ [Step Model]
steps)) ->
Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool
True
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Bool -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 ([Step Model] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Step Model]
steps) String
"empty"
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
10 ([Step Model] -> Bool
hasFanout [Step Model]
steps) String
"reach fanout"
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 ([Step Model] -> Int
countContests [Step Model]
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) String
"has multiple contests"
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 ([Step Model] -> Bool
containSomeSnapshots [Step Model]
steps) String
"has some snapshots"
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
5 ([Step Model] -> Bool
closeNonInitial [Step Model]
steps) String
"close with non initial snapshots"
where
containSomeSnapshots :: [Step Model] -> Bool
containSomeSnapshots =
(Step Model -> Bool) -> [Step Model] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Step Model -> Bool) -> [Step Model] -> Bool)
-> (Step Model -> Bool) -> [Step Model] -> Bool
forall a b. (a -> b) -> a -> b
$
\(Var a
_ := ActionWithPolarity{Action Model a
polarAction :: Action Model a
polarAction :: forall state a. ActionWithPolarity state a -> Action state a
polarAction}) -> case Action Model a
polarAction of
ProduceSnapshots [SnapshotNumber]
snapshots -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [SnapshotNumber] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SnapshotNumber]
snapshots
Action Model a
_ -> Bool
False
hasFanout :: [Step Model] -> Bool
hasFanout =
(Step Model -> Bool) -> [Step Model] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Step Model -> Bool) -> [Step Model] -> Bool)
-> (Step Model -> Bool) -> [Step Model] -> Bool
forall a b. (a -> b) -> a -> b
$
\(Var a
_ := ActionWithPolarity{Action Model a
polarAction :: forall state a. ActionWithPolarity state a -> Action state a
polarAction :: Action Model a
polarAction}) -> case Action Model a
polarAction of
Fanout{} -> Bool
True
Action Model a
_ -> Bool
False
countContests :: [Step Model] -> Int
countContests =
[Step Model] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
([Step Model] -> Int)
-> ([Step Model] -> [Step Model]) -> [Step Model] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step Model -> Bool) -> [Step Model] -> [Step Model]
forall a. (a -> Bool) -> [a] -> [a]
filter
( \(Var a
_ := ActionWithPolarity{Action Model a
polarAction :: forall state a. ActionWithPolarity state a -> Action state a
polarAction :: Action Model a
polarAction}) -> case Action Model a
polarAction of
Contest{} -> Bool
True
Action Model a
_ -> Bool
False
)
closeNonInitial :: [Step Model] -> Bool
closeNonInitial =
(Step Model -> Bool) -> [Step Model] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Step Model -> Bool) -> [Step Model] -> Bool)
-> (Step Model -> Bool) -> [Step Model] -> Bool
forall a b. (a -> b) -> a -> b
$
\(Var a
_ := ActionWithPolarity{Action Model a
polarAction :: forall state a. ActionWithPolarity state a -> Action state a
polarAction :: Action Model a
polarAction}) -> case Action Model a
polarAction of
Close{SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> SnapshotNumber
snapshotNumber} -> SnapshotNumber
snapshotNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Ord a => a -> a -> Bool
> SnapshotNumber
0
Action Model a
_ -> Bool
False
prop_runActions :: Actions Model -> Property
prop_runActions :: Actions Model -> Property
prop_runActions Actions Model
actions =
PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO () -> Property) -> PropertyM IO () -> Property
forall a b. (a -> b) -> a -> b
$
PropertyM IO (Annotated Model, Env IO) -> PropertyM IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Actions Model -> PropertyM IO (Annotated Model, Env IO)
forall state (m :: * -> *).
(StateModel state, RunModel state m) =>
Actions state -> PropertyM m (Annotated state, Env m)
runActions Actions Model
actions)
data Model = Model
{ Model -> [SnapshotNumber]
snapshots :: [SnapshotNumber]
, Model -> State
headState :: State
, Model -> Var (UTxO' (TxOut CtxUTxO Era))
utxoV :: Var UTxO
, Model -> [Actor]
alreadyContested :: [Actor]
}
deriving (Int -> Model -> ShowS
[Model] -> ShowS
Model -> String
(Int -> Model -> ShowS)
-> (Model -> String) -> ([Model] -> ShowS) -> Show Model
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Model -> ShowS
showsPrec :: Int -> Model -> ShowS
$cshow :: Model -> String
show :: Model -> String
$cshowList :: [Model] -> ShowS
showList :: [Model] -> ShowS
Show)
data State
= Open
| Closed
| Final
deriving (Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [State] -> ShowS
Show, State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq)
data Actor = Alice | Bob | Carol
deriving (Int -> Actor -> ShowS
[Actor] -> ShowS
Actor -> String
(Int -> Actor -> ShowS)
-> (Actor -> String) -> ([Actor] -> ShowS) -> Show Actor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Actor -> ShowS
showsPrec :: Int -> Actor -> ShowS
$cshow :: Actor -> String
show :: Actor -> String
$cshowList :: [Actor] -> ShowS
showList :: [Actor] -> ShowS
Show, Actor -> Actor -> Bool
(Actor -> Actor -> Bool) -> (Actor -> Actor -> Bool) -> Eq Actor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Actor -> Actor -> Bool
== :: Actor -> Actor -> Bool
$c/= :: Actor -> Actor -> Bool
/= :: Actor -> Actor -> Bool
Eq)
instance StateModel Model where
data Action Model a where
ProduceSnapshots :: [SnapshotNumber] -> Action Model ()
Close :: {Action Model (UTxO' (TxOut CtxUTxO Era)) -> Actor
actor :: Actor, Action Model (UTxO' (TxOut CtxUTxO Era)) -> SnapshotNumber
snapshotNumber :: SnapshotNumber} -> Action Model UTxO
Contest :: {actor :: Actor, snapshotNumber :: SnapshotNumber} -> Action Model UTxO
Fanout :: Action Model ()
Stop :: Action Model ()
arbitraryAction :: VarContext -> Model -> Gen (Any (Action Model))
arbitraryAction :: VarContext -> Model -> Gen (Any (Action Model))
arbitraryAction VarContext
_lookup Model{State
$sel:headState:Model :: Model -> State
headState :: State
headState, [SnapshotNumber]
$sel:snapshots:Model :: Model -> [SnapshotNumber]
snapshots :: [SnapshotNumber]
snapshots, [Actor]
$sel:alreadyContested:Model :: Model -> [Actor]
alreadyContested :: [Actor]
alreadyContested} =
case State
headState of
State
Open ->
[Gen (Any (Action Model))] -> Gen (Any (Action Model))
forall a. [Gen a] -> Gen a
oneof
[
Action Model () -> Any (Action Model)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action Model () -> Any (Action Model))
-> ([SnapshotNumber] -> Action Model ())
-> [SnapshotNumber]
-> Any (Action Model)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SnapshotNumber] -> Action Model ()
ProduceSnapshots ([SnapshotNumber] -> Any (Action Model))
-> Gen [SnapshotNumber] -> Gen (Any (Action Model))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [SnapshotNumber]
forall a. Arbitrary a => Gen a
arbitrary
, do
Actor
actor <- [Actor] -> Gen Actor
forall a. [a] -> Gen a
elements [Actor]
allActors
SnapshotNumber
snapshotNumber <- [SnapshotNumber] -> Gen SnapshotNumber
forall a. [a] -> Gen a
elements (SnapshotNumber
0 SnapshotNumber -> [SnapshotNumber] -> [SnapshotNumber]
forall a. a -> [a] -> [a]
: [SnapshotNumber]
snapshots)
Any (Action Model) -> Gen (Any (Action Model))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action Model) -> Gen (Any (Action Model)))
-> Any (Action Model) -> Gen (Any (Action Model))
forall a b. (a -> b) -> a -> b
$ Action Model (UTxO' (TxOut CtxUTxO Era)) -> Any (Action Model)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some (Action Model (UTxO' (TxOut CtxUTxO Era)) -> Any (Action Model))
-> Action Model (UTxO' (TxOut CtxUTxO Era)) -> Any (Action Model)
forall a b. (a -> b) -> a -> b
$ Close{Actor
$sel:actor:ProduceSnapshots :: Actor
actor :: Actor
actor, SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}
]
State
Closed ->
case Maybe (Gen (Any (Action Model)))
maybeGenContest of
Maybe (Gen (Any (Action Model)))
Nothing -> Gen (Any (Action Model))
genFanout
Just Gen (Any (Action Model))
contestAction -> [Gen (Any (Action Model))] -> Gen (Any (Action Model))
forall a. [Gen a] -> Gen a
oneof [Gen (Any (Action Model))
contestAction, Gen (Any (Action Model))
genFanout]
State
Final -> Any (Action Model) -> Gen (Any (Action Model))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action Model) -> Gen (Any (Action Model)))
-> Any (Action Model) -> Gen (Any (Action Model))
forall a b. (a -> b) -> a -> b
$ Action Model () -> Any (Action Model)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Action Model ()
Stop
where
genFanout :: Gen (Any (Action Model))
genFanout = Any (Action Model) -> Gen (Any (Action Model))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action Model) -> Gen (Any (Action Model)))
-> Any (Action Model) -> Gen (Any (Action Model))
forall a b. (a -> b) -> a -> b
$ Action Model () -> Any (Action Model)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Action Model ()
Fanout
possibleContesters :: [Actor]
possibleContesters = [Actor]
allActors [Actor] -> [Actor] -> [Actor]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Actor]
alreadyContested
maybeGenContest :: Maybe (Gen (Any (Action Model)))
maybeGenContest
| [Actor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Actor]
possibleContesters Bool -> Bool -> Bool
|| [SnapshotNumber] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SnapshotNumber]
snapshots = Maybe (Gen (Any (Action Model)))
forall a. Maybe a
Nothing
| Bool
otherwise = Gen (Any (Action Model)) -> Maybe (Gen (Any (Action Model)))
forall a. a -> Maybe a
Just (Gen (Any (Action Model)) -> Maybe (Gen (Any (Action Model))))
-> Gen (Any (Action Model)) -> Maybe (Gen (Any (Action Model)))
forall a b. (a -> b) -> a -> b
$ do
Actor
actor <- [Actor] -> Gen Actor
forall a. [a] -> Gen a
elements [Actor]
possibleContesters
SnapshotNumber
snapshotNumber <- [SnapshotNumber] -> Gen SnapshotNumber
forall a. [a] -> Gen a
elements [SnapshotNumber]
snapshots
Any (Action Model) -> Gen (Any (Action Model))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Any (Action Model) -> Gen (Any (Action Model)))
-> Any (Action Model) -> Gen (Any (Action Model))
forall a b. (a -> b) -> a -> b
$ Action Model (UTxO' (TxOut CtxUTxO Era)) -> Any (Action Model)
forall a (f :: * -> *). (Typeable a, Eq (f a)) => f a -> Any f
Some Contest{Actor
$sel:actor:ProduceSnapshots :: Actor
actor :: Actor
actor, SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}
initialState :: Model
initialState =
Model
{ $sel:snapshots:Model :: [SnapshotNumber]
snapshots = []
, $sel:headState:Model :: State
headState = State
Open
, $sel:utxoV:Model :: Var (UTxO' (TxOut CtxUTxO Era))
utxoV = Int -> Var (UTxO' (TxOut CtxUTxO Era))
forall a. Int -> Var a
mkVar (-Int
1)
, $sel:alreadyContested:Model :: [Actor]
alreadyContested = []
}
nextState :: Model -> Action Model a -> Var a -> Model
nextState :: forall a. Model -> Action Model a -> Var a -> Model
nextState Model
m Action Model a
R:ActionModela a
Stop Var a
_ = Model
m
nextState Model
m Action Model a
t Var a
result =
case Action Model a
t of
ProduceSnapshots [SnapshotNumber]
snapshots -> Model
m{snapshots = snapshots}
Close{SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} ->
Model
m
{ headState = Closed
, utxoV = result
, snapshots = filter (> snapshotNumber) $ snapshots m
, alreadyContested = []
}
Contest{Actor
$sel:actor:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> Actor
actor :: Actor
actor, SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} ->
Model
m
{ headState = Closed
, utxoV = result
, snapshots = filter (> snapshotNumber) $ snapshots m
, alreadyContested = actor : alreadyContested m
}
Action Model a
R:ActionModela a
Fanout -> Model
m{headState = Final}
precondition :: Model -> Action Model a -> Bool
precondition :: forall a. Model -> Action Model a -> Bool
precondition Model{$sel:headState:Model :: Model -> State
headState = State
Final} Action Model a
R:ActionModela a
Stop =
Bool
False
precondition Model{State
$sel:headState:Model :: Model -> State
headState :: State
headState} Contest{SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} =
State
headState State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
Closed Bool -> Bool -> Bool
&& SnapshotNumber
snapshotNumber SnapshotNumber -> SnapshotNumber -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotNumber
0
precondition Model
_ Action Model a
_ = Bool
True
instance HasVariables Model where
getAllVariables :: Model -> Set (Any Var)
getAllVariables = Model -> Set (Any Var)
forall a. Monoid a => a
mempty
instance HasVariables (Action Model a) where
getAllVariables :: Action Model a -> Set (Any Var)
getAllVariables = Action Model a -> Set (Any Var)
forall a. Monoid a => a
mempty
deriving instance Eq (Action Model a)
deriving instance Show (Action Model a)
instance RunModel Model IO where
perform :: Model -> Action Model a -> LookUp IO -> IO a
perform :: forall a. Model -> Action Model a -> LookUp IO -> IO a
perform Model{Var (UTxO' (TxOut CtxUTxO Era))
$sel:utxoV:Model :: Model -> Var (UTxO' (TxOut CtxUTxO Era))
utxoV :: Var (UTxO' (TxOut CtxUTxO Era))
utxoV, [Actor]
$sel:alreadyContested:Model :: Model -> [Actor]
alreadyContested :: [Actor]
alreadyContested} Action Model a
action LookUp IO
lookupVar = do
case Action Model a
action of
ProduceSnapshots [SnapshotNumber]
_snapshots -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Close{Actor
$sel:actor:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> Actor
actor :: Actor
actor, SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} -> do
Tx
tx <- HasCallStack => Actor -> ConfirmedSnapshot Tx -> IO Tx
Actor -> ConfirmedSnapshot Tx -> IO Tx
newCloseTx Actor
actor (ConfirmedSnapshot Tx -> IO Tx) -> ConfirmedSnapshot Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> ConfirmedSnapshot Tx
correctlySignedSnapshot SnapshotNumber
snapshotNumber
UTxO' (TxOut CtxUTxO Era) -> Tx -> IO ()
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
UTxO' (TxOut CtxUTxO Era) -> Tx -> m ()
validateTx UTxO' (TxOut CtxUTxO Era)
openHeadUTxO Tx
tx
UTxO' (TxOut CtxUTxO Era)
-> Tx -> (HeadObservation -> Maybe ()) -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
UTxO' (TxOut CtxUTxO Era)
-> Tx -> (HeadObservation -> Maybe a) -> m a
observeTxMatching UTxO' (TxOut CtxUTxO Era)
openHeadUTxO Tx
tx ((HeadObservation -> Maybe ()) -> IO ())
-> (HeadObservation -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
Tx.Close{} -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
HeadObservation
_ -> Maybe ()
forall a. Maybe a
Nothing
UTxO' (TxOut CtxUTxO Era) -> IO (UTxO' (TxOut CtxUTxO Era))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO Era) -> IO (UTxO' (TxOut CtxUTxO Era)))
-> UTxO' (TxOut CtxUTxO Era) -> IO (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ Tx -> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
adjustUTxO Tx
tx UTxO' (TxOut CtxUTxO Era)
openHeadUTxO
Contest{Actor
$sel:actor:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> Actor
actor :: Actor
actor, SnapshotNumber
$sel:snapshotNumber:ProduceSnapshots :: Action Model (UTxO' (TxOut CtxUTxO Era)) -> SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber} -> do
let utxo :: Realized IO (UTxO' (TxOut CtxUTxO Era))
utxo = Var (UTxO' (TxOut CtxUTxO Era))
-> Realized IO (UTxO' (TxOut CtxUTxO Era))
LookUp IO
lookupVar Var (UTxO' (TxOut CtxUTxO Era))
utxoV
Tx
tx <- HasCallStack =>
UTxO' (TxOut CtxUTxO Era) -> Actor -> ConfirmedSnapshot Tx -> IO Tx
UTxO' (TxOut CtxUTxO Era) -> Actor -> ConfirmedSnapshot Tx -> IO Tx
newContestTx UTxO' (TxOut CtxUTxO Era)
Realized IO (UTxO' (TxOut CtxUTxO Era))
utxo Actor
actor (ConfirmedSnapshot Tx -> IO Tx) -> ConfirmedSnapshot Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> ConfirmedSnapshot Tx
correctlySignedSnapshot SnapshotNumber
snapshotNumber
UTxO' (TxOut CtxUTxO Era) -> Tx -> IO ()
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
UTxO' (TxOut CtxUTxO Era) -> Tx -> m ()
validateTx UTxO' (TxOut CtxUTxO Era)
Realized IO (UTxO' (TxOut CtxUTxO Era))
utxo Tx
tx
observation :: ContestObservation
observation@Tx.ContestObservation{[PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:ContestObservation :: ContestObservation -> [PubKeyHash]
contesters} <-
UTxO' (TxOut CtxUTxO Era)
-> Tx
-> (HeadObservation -> Maybe ContestObservation)
-> IO ContestObservation
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
UTxO' (TxOut CtxUTxO Era)
-> Tx -> (HeadObservation -> Maybe a) -> m a
observeTxMatching UTxO' (TxOut CtxUTxO Era)
Realized IO (UTxO' (TxOut CtxUTxO Era))
utxo Tx
tx ((HeadObservation -> Maybe ContestObservation)
-> IO ContestObservation)
-> (HeadObservation -> Maybe ContestObservation)
-> IO ContestObservation
forall a b. (a -> b) -> a -> b
$ \case
Tx.Contest ContestObservation
obs -> ContestObservation -> Maybe ContestObservation
forall a. a -> Maybe a
Just ContestObservation
obs
HeadObservation
_ -> Maybe ContestObservation
forall a. Maybe a
Nothing
let newContesters :: [Actor]
newContesters = Actor
actor Actor -> [Actor] -> [Actor]
forall a. a -> [a] -> [a]
: [Actor]
alreadyContested
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PubKeyHash] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PubKeyHash]
contesters Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Actor] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Actor]
newContesters) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> ([Text] -> String) -> [Text] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> Text
forall a. IsString a => String -> a
fromString
(String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ String
"Expected contesters " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Actor] -> String
forall a. Show a => a -> String
show [Actor]
newContesters String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", but observed only " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [PubKeyHash] -> String
forall a. Show a => a -> String
show [PubKeyHash]
contesters
, Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ContestObservation -> Text
forall a. Show a => a -> Text
pShowNoColor ContestObservation
observation
, String
"Transaction: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era) -> Tx -> String
renderTxWithUTxO UTxO' (TxOut CtxUTxO Era)
Realized IO (UTxO' (TxOut CtxUTxO Era))
utxo Tx
tx
]
UTxO' (TxOut CtxUTxO Era) -> IO (UTxO' (TxOut CtxUTxO Era))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO Era) -> IO (UTxO' (TxOut CtxUTxO Era)))
-> UTxO' (TxOut CtxUTxO Era) -> IO (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ Tx -> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
adjustUTxO Tx
tx UTxO' (TxOut CtxUTxO Era)
Realized IO (UTxO' (TxOut CtxUTxO Era))
utxo
Action Model a
R:ActionModela a
Fanout -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Action Model a
R:ActionModela a
Stop -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
allActors :: [Actor]
allActors :: [Actor]
allActors = [Actor
Alice, Actor
Bob, Actor
Carol]
snapshotUTxO :: SnapshotNumber -> UTxO
snapshotUTxO :: SnapshotNumber -> UTxO' (TxOut CtxUTxO Era)
snapshotUTxO SnapshotNumber
n = (Gen (UTxO' (TxOut CtxUTxO Era)) -> Int -> UTxO' (TxOut CtxUTxO Era)
forall a. Gen a -> Int -> a
`generateWith` SnapshotNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotNumber
n) (Gen (UTxO' (TxOut CtxUTxO Era)) -> UTxO' (TxOut CtxUTxO Era))
-> (Gen (UTxO' (TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era)))
-> Gen (UTxO' (TxOut CtxUTxO Era))
-> UTxO' (TxOut CtxUTxO Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Gen (UTxO' (TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era))
forall a. Int -> Gen a -> Gen a
resize Int
1 (Gen (UTxO' (TxOut CtxUTxO Era)) -> UTxO' (TxOut CtxUTxO Era))
-> Gen (UTxO' (TxOut CtxUTxO Era)) -> UTxO' (TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ do
UTxO' (TxOut CtxUTxO Era)
aliceUTxO <- VerificationKey PaymentKey -> Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOFor (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
`genForParty` Party
Fixture.alice)
UTxO' (TxOut CtxUTxO Era)
bobUTxO <- VerificationKey PaymentKey -> Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOFor (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
`genForParty` Party
Fixture.bob)
UTxO' (TxOut CtxUTxO Era)
carolUTxO <- VerificationKey PaymentKey -> Gen (UTxO' (TxOut CtxUTxO Era))
genUTxOFor (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
`genForParty` Party
Fixture.carol)
UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era)))
-> UTxO' (TxOut CtxUTxO Era) -> Gen (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO Era)
aliceUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
bobUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
carolUTxO
correctlySignedSnapshot :: SnapshotNumber -> ConfirmedSnapshot Tx
correctlySignedSnapshot :: SnapshotNumber -> ConfirmedSnapshot Tx
correctlySignedSnapshot = \case
SnapshotNumber
0 ->
InitialSnapshot
{
$sel:headId:InitialSnapshot :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId
, $sel:initialUTxO:InitialSnapshot :: UTxOType Tx
initialUTxO = SnapshotNumber -> UTxO' (TxOut CtxUTxO Era)
snapshotUTxO SnapshotNumber
0
}
SnapshotNumber
number -> ConfirmedSnapshot{Snapshot Tx
snapshot :: Snapshot Tx
$sel:snapshot:InitialSnapshot :: Snapshot Tx
snapshot, MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
$sel:signatures:InitialSnapshot :: MultiSignature (Snapshot Tx)
signatures}
where
snapshot :: Snapshot Tx
snapshot =
Snapshot
{ $sel:headId:Snapshot :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId
, SnapshotNumber
$sel:number:Snapshot :: SnapshotNumber
number :: SnapshotNumber
number
, $sel:utxo:Snapshot :: UTxOType Tx
utxo = SnapshotNumber -> UTxO' (TxOut CtxUTxO Era)
snapshotUTxO SnapshotNumber
number
, $sel:confirmed:Snapshot :: [TxIdType Tx]
confirmed = []
}
signatures :: MultiSignature (Snapshot Tx)
signatures = [Signature (Snapshot Tx)] -> MultiSignature (Snapshot Tx)
forall {k} (a :: k). [Signature a] -> MultiSignature a
aggregate [SigningKey HydraKey -> Snapshot Tx -> Signature (Snapshot Tx)
forall a.
SignableRepresentation a =>
SigningKey HydraKey -> a -> Signature a
sign SigningKey HydraKey
sk Snapshot Tx
snapshot | SigningKey HydraKey
sk <- [SigningKey HydraKey
Fixture.aliceSk, SigningKey HydraKey
Fixture.bobSk, SigningKey HydraKey
Fixture.carolSk]]
openHeadUTxO :: UTxO
openHeadUTxO :: UTxO' (TxOut CtxUTxO Era)
openHeadUTxO =
(TxIn, TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. (TxIn, out) -> UTxO' out
UTxO.singleton (TxIn
headTxIn, TxOut CtxUTxO Era
openHeadTxOut)
UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> ScriptRegistry -> UTxO' (TxOut CtxUTxO Era)
registryUTxO ScriptRegistry
testScriptRegistry
where
headTxIn :: TxIn
headTxIn = Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary Gen TxIn -> Int -> TxIn
forall a. Gen a -> Int -> a
`generateWith` Int
42
openHeadTxOut :: TxOut CtxUTxO Era
openHeadTxOut =
NetworkId -> PolicyId -> TxOutDatum CtxUTxO -> TxOut CtxUTxO Era
forall ctx. NetworkId -> PolicyId -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput NetworkId
Fixture.testNetworkId PolicyId
Fixture.testPolicyId TxOutDatum CtxUTxO
forall {ctx}. TxOutDatum ctx Era
openHeadDatum
TxOut CtxUTxO Era
-> (TxOut CtxUTxO Era -> TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. a -> (a -> b) -> b
& [VerificationKey PaymentKey]
-> TxOut CtxUTxO Era -> TxOut CtxUTxO Era
addParticipationTokens [VerificationKey PaymentKey
Fixture.alicePVk, VerificationKey PaymentKey
Fixture.bobPVk, VerificationKey PaymentKey
Fixture.carolPVk]
openHeadDatum :: TxOutDatum ctx Era
openHeadDatum =
State -> TxOutDatum ctx Era
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline
Head.Open
{ $sel:parties:Initial :: [Party]
parties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party
Fixture.alice, Party
Fixture.bob, Party
Fixture.carol]
, $sel:utxoHash:Initial :: Hash
utxoHash = ByteString -> Hash
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> Hash) -> ByteString -> Hash
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx (UTxOType Tx -> ByteString) -> UTxOType Tx -> ByteString
forall a b. (a -> b) -> a -> b
$ SnapshotNumber -> UTxO' (TxOut CtxUTxO Era)
snapshotUTxO SnapshotNumber
0
, $sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
CP.toChain ContestationPeriod
Fixture.cperiod
, $sel:headId:Initial :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol (HeadId -> CurrencySymbol) -> HeadId -> CurrencySymbol
forall a b. (a -> b) -> a -> b
$ PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId
}
newCloseTx :: HasCallStack => Actor -> ConfirmedSnapshot Tx -> IO Tx
newCloseTx :: HasCallStack => Actor -> ConfirmedSnapshot Tx -> IO Tx
newCloseTx Actor
actor ConfirmedSnapshot Tx
snapshot =
(CloseTxError -> IO Tx)
-> (Tx -> IO Tx) -> Either CloseTxError Tx -> IO Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO Tx
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Tx)
-> (CloseTxError -> String) -> CloseTxError -> IO Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CloseTxError -> String
forall a. Show a => a -> String
show) Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CloseTxError Tx -> IO Tx)
-> Either CloseTxError Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$
ChainContext
-> UTxO' (TxOut CtxUTxO Era)
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close
(Actor -> ChainContext
actorChainContext Actor
actor)
UTxO' (TxOut CtxUTxO Era)
openHeadUTxO
(PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId)
HeadParameters
Fixture.testHeadParameters
ConfirmedSnapshot Tx
snapshot
SlotNo
lowerBound
PointInTime
upperBound
where
lowerBound :: SlotNo
lowerBound = SlotNo
0
upperBound :: PointInTime
upperBound = (SlotNo
0, POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0)
newContestTx :: HasCallStack => UTxO -> Actor -> ConfirmedSnapshot Tx -> IO Tx
newContestTx :: HasCallStack =>
UTxO' (TxOut CtxUTxO Era) -> Actor -> ConfirmedSnapshot Tx -> IO Tx
newContestTx UTxO' (TxOut CtxUTxO Era)
spendableUTxO Actor
actor ConfirmedSnapshot Tx
snapshot =
(ContestTxError -> IO Tx)
-> (Tx -> IO Tx) -> Either ContestTxError Tx -> IO Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO Tx
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Tx)
-> (ContestTxError -> String) -> ContestTxError -> IO Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContestTxError -> String
forall a. Show a => a -> String
show) Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ContestTxError Tx -> IO Tx)
-> Either ContestTxError Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$
ChainContext
-> UTxO' (TxOut CtxUTxO Era)
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest
(Actor -> ChainContext
actorChainContext Actor
actor)
UTxO' (TxOut CtxUTxO Era)
spendableUTxO
(PolicyId -> HeadId
mkHeadId PolicyId
Fixture.testPolicyId)
ContestationPeriod
Fixture.cperiod
ConfirmedSnapshot Tx
snapshot
PointInTime
currentTime
where
currentTime :: PointInTime
currentTime = (SlotNo
0, POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0)
actorChainContext :: Actor -> ChainContext
actorChainContext :: Actor -> ChainContext
actorChainContext Actor
actor =
ChainContext
{ $sel:networkId:ChainContext :: NetworkId
networkId = NetworkId
Fixture.testNetworkId
, $sel:ownVerificationKey:ChainContext :: VerificationKey PaymentKey
ownVerificationKey =
case Actor
actor of
Actor
Alice -> VerificationKey PaymentKey
Fixture.alicePVk
Actor
Bob -> VerificationKey PaymentKey
Fixture.bobPVk
Actor
Carol -> VerificationKey PaymentKey
Fixture.carolPVk
, $sel:ownParty:ChainContext :: Party
ownParty =
case Actor
actor of
Actor
Alice -> Party
Fixture.alice
Actor
Bob -> Party
Fixture.bob
Actor
Carol -> Party
Fixture.carol
, $sel:scriptRegistry:ChainContext :: ScriptRegistry
scriptRegistry = ScriptRegistry
testScriptRegistry
}
testScriptRegistry :: ScriptRegistry
testScriptRegistry :: ScriptRegistry
testScriptRegistry = Gen ScriptRegistry
genScriptRegistry Gen ScriptRegistry -> Int -> ScriptRegistry
forall a. Gen a -> Int -> a
`generateWith` Int
42
validateTx :: (HasCallStack, MonadThrow m) => UTxO -> Tx -> m ()
validateTx :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
UTxO' (TxOut CtxUTxO Era) -> Tx -> m ()
validateTx UTxO' (TxOut CtxUTxO Era)
utxo Tx
tx =
case Tx
-> UTxO' (TxOut CtxUTxO Era)
-> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO' (TxOut CtxUTxO Era)
utxo of
Left EvaluationError
err ->
String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ EvaluationError -> String
forall a. Show a => a -> String
show EvaluationError
err
Right EvaluationReport
redeemerReport ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Either ScriptExecutionError ExecutionUnits -> Bool)
-> [Either ScriptExecutionError ExecutionUnits] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isLeft (EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
redeemerReport)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m ()) -> ([Text] -> String) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
String -> Text
forall a. IsString a => String -> a
fromString
(String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ String
"Transaction evaluation failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era) -> Tx -> String
renderTxWithUTxO UTxO' (TxOut CtxUTxO Era)
utxo Tx
tx
, String
"Some redeemers failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall a. Show a => a -> String
show EvaluationReport
redeemerReport
]
observeTxMatching :: (HasCallStack, MonadThrow m) => UTxO -> Tx -> (HeadObservation -> Maybe a) -> m a
observeTxMatching :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
UTxO' (TxOut CtxUTxO Era)
-> Tx -> (HeadObservation -> Maybe a) -> m a
observeTxMatching UTxO' (TxOut CtxUTxO Era)
utxo Tx
tx HeadObservation -> Maybe a
predicate = do
let res :: HeadObservation
res = NetworkId -> UTxO' (TxOut CtxUTxO Era) -> Tx -> HeadObservation
observeHeadTx NetworkId
Fixture.testNetworkId UTxO' (TxOut CtxUTxO Era)
utxo Tx
tx
case HeadObservation -> Maybe a
predicate HeadObservation
res of
Just a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Maybe a
Nothing -> String -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Observation result not matching expectation, got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeadObservation -> String
forall a. Show a => a -> String
show HeadObservation
res