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)

-- * Model

data Model = Model
  { Model -> [SnapshotNumber]
snapshots :: [SnapshotNumber]
  , Model -> State
headState :: State
  , Model -> Var (UTxO' (TxOut CtxUTxO Era))
utxoV :: Var UTxO
  -- ^ Last known, spendable 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 ()
    -- \| Helper action to identify the terminal state 'Final' and shorten
    -- traces using the 'precondition'.
    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
          [ -- NOTE: non-continuous snapshot numbers are allowed in this model
            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 ()

-- * Fixtures and glue code

-- | List of all model actors corresponding to the fixtures used.
allActors :: [Actor]
allActors :: [Actor]
allActors = [Actor
Alice, Actor
Bob, Actor
Carol]

-- | A "random" UTxO distribution for a given snapshot number. This always
-- contains one UTxO for alice, bob, and 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

-- | A model of a correctly signed snapshot. Given a snapshot number a snapshot
-- signed by all participants (alice, bob and carol) with some UTxO contained is
-- produced.
correctlySignedSnapshot :: SnapshotNumber -> ConfirmedSnapshot Tx
correctlySignedSnapshot :: SnapshotNumber -> ConfirmedSnapshot Tx
correctlySignedSnapshot = \case
  SnapshotNumber
0 ->
    InitialSnapshot
      { -- -- NOTE: The close validator would not check headId on close with
        -- initial snapshot, but we need to provide it still.
        $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]]

-- | UTxO of the open head on-chain. NOTE: This uses fixtures for headId, parties, and cperiod.
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
        }

-- | Creates a transaction that closes 'openHeadUTxO' with given the snapshot.
-- NOTE: This uses fixtures for headId, parties (alice, bob, carol),
-- contestation period and also claims to close at time 0 resulting in a
-- contestation deadline of 0 + cperiod.
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)

-- | Creates a contest transaction using given utxo and contesting with given
-- snapshot. NOTE: This uses fixtures for headId, contestation period and also
-- claims to contest at time 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)

-- | Fixture for the chain context of a model 'Actor' on 'testNetworkId'. Uses a generated 'ScriptRegistry'.
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

-- * Helpers

-- | Thin wrapper around 'evaluateTx' that fails with 'failure' if any of the
-- scripts/redeemers fail to evaluate.
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
                ]

-- | Expect to observe a transaction matching given predicate. This fails with
-- 'failure' if the predicate yields 'Nothing'.
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