Skip to content

Commit

Permalink
TxSpec: Mutate snapshots and utxo to produce expected errors
Browse files Browse the repository at this point in the history
  • Loading branch information
@v0d1ch
v0d1ch committed Jun 4, 2024
1 parent 04e9fc5 commit f9f190e
Showing 1 changed file with 67 additions and 49 deletions.
116 changes: 67 additions & 49 deletions hydra-node/test/Hydra/Chain/Direct/TxSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import GHC.Natural (naturalFromInteger)
import Hydra.Cardano.Api.Pretty (renderTx, renderTxWithUTxO)
import Hydra.Chain (CommitBlueprintTx (..), HeadParameters (..))
import Hydra.Chain.Direct.Contract.Close (healthyContestationPeriodSeconds, healthyOpenHeadDatum, healthyOpenHeadTxOut)
import Hydra.Chain.Direct.Contract.Close (healthyContestationDeadline, healthyContestationPeriodSeconds, healthyOpenHeadDatum, healthyOpenHeadTxOut)
import Hydra.Chain.Direct.Contract.Commit (commitSigningKey, healthyInitialTxIn, healthyInitialTxOut)
import Hydra.Chain.Direct.Fixture (
epochInfo,
Expand All @@ -52,8 +52,8 @@ import Hydra.Chain.Direct.Fixture (
testSeedInput,
)
import Hydra.Chain.Direct.Fixture qualified as Fixture
import Hydra.Chain.Direct.ScriptRegistry (ScriptRegistry, genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.State (ChainContext (..), HasKnownUTxO (getKnownUTxO), close, contest, decrement, fanout, genChainStateWithTx)
import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.State (ChainContext (..), HasKnownUTxO (getKnownUTxO), close, contest, decrement, fanout, genChainStateWithTx, utxoOfThisHead)
import Hydra.Chain.Direct.State qualified as Transition
import Hydra.Chain.Direct.Tx (
HeadObservation (..),
Expand All @@ -78,16 +78,19 @@ import Hydra.Chain.Direct.Wallet (ErrCoverFee (..), coverFee_)
import Hydra.ContestationPeriod (ContestationPeriod (..))
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Error (toErrorCode)
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadError (HeadError (SnapshotNumberMismatch, TooOldSnapshot))
import Hydra.Contract.HeadState (utxoHash)
import Hydra.Contract.HeadState qualified as HeadState
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Contract.Initial qualified as Initial
import Hydra.Crypto (aggregate, sign)
import Hydra.Data.ContestationPeriod (contestationPeriodFromDiffTime)
import Hydra.HeadId (HeadId (..))
import Hydra.Ledger (hashUTxO)
import Hydra.Ledger.Cardano (adaOnly, addInputs, addReferenceInputs, addVkInputs, emptyTxBody, genOneUTxOFor, genTxOutWithReferenceScript, genUTxO1, genUTxOAdaOnlyOfSize, genValue, genVerificationKey, unsafeBuildTransaction)
import Hydra.Ledger.Cardano.Evaluate (EvaluationReport, evaluateTx, maxTxExecutionUnits, propTransactionEvaluates)
import Hydra.Party (Party)
import Hydra.Party (Party, partyToChain)
import Hydra.Plutus.Extras (posixFromUTCTime)
import Hydra.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber)
import PlutusLedgerApi.Test.Examples qualified as Plutus
import PlutusLedgerApi.V2 (toBuiltin)
Expand Down Expand Up @@ -263,7 +266,7 @@ spec =
forAllBlind genPerfectModelSnapshot $ \modelSnapshot -> do
let (utxo', utxoToDecommit') = generateUTxOFromModelSnapshot modelSnapshot
let headId' = mkHeadId Fixture.testPolicyId
let datum = toUTxOContext (mkTxOutDatumInline $ healthyOpenHeadDatum{utxoHash = toBuiltin $ hashUTxO @Tx utxo'})
let datum = toUTxOContext (mkTxOutDatumInline $ healthyOpenHeadDatum{HeadState.utxoHash = toBuiltin $ hashUTxO @Tx utxo'})
let decommitValue = foldMap (txOutValue . snd) (UTxO.pairs utxoToDecommit')
let headTxIn = generateWith arbitrary 42
let spendableUTxO =
Expand All @@ -274,33 +277,53 @@ spec =

let parameters = HeadParameters (UnsafeContestationPeriod $ naturalFromInteger healthyContestationPeriodSeconds) [alice, bob, carol]

let createCloseDatumFromOpen (snapshot, spendable) =
let headScript = fromPlutusScript @PlutusScriptV2 Head.validatorScript
in case UTxO.find (isScriptTxOut headScript) (utxoOfThisHead Fixture.testPolicyId spendable) of
Nothing -> error "Missing head output"
Just (headIn, headOut) ->
UTxO.singleton (headIn, modifyTxOutDatum (const closeDatum) headOut) <> registryUTxO scriptRegistry
where
Snapshot{utxo, utxoToDecommit} = snapshot
closeDatum =
mkTxOutDatumInline
HeadState.Closed
{ parties = partyToChain <$> [alice, bob, carol]
, snapshotNumber = 2
, utxoHash = toBuiltin $ hashUTxO @Tx utxo
, utxoToDecommitHash = toBuiltin $ hashUTxO @Tx (fromMaybe mempty utxoToDecommit)
, contestationDeadline = posixFromUTCTime healthyContestationDeadline
, contestationPeriod = contestationPeriodFromDiffTime 0
, headId = headIdToCurrencySymbol headId'
, contesters = []
}

let decrementSnapshots =
[ (decrementSnapshot, decrementSnapshot, Nothing)
, (mutateSnapshotNumber (\a -> abs $ a - 1) decrementSnapshot, decrementSnapshot, Just SnapshotNumberMismatch)
[ (decrementSnapshot, snd, Nothing)
, (mutateSnapshotNumber (\a -> abs $ a - 1) decrementSnapshot, snd, Just SnapshotNumberMismatch)
]

let closeSnapshots =
[ (decrementSnapshot, decrementSnapshot, Nothing)
, (mutateSnapshotNumber (\a -> abs $ a - 1) decrementSnapshot, decrementSnapshot, Just SnapshotNumberMismatch)
[ (decrementSnapshot, snd, Nothing)
, (mutateSnapshotNumber (const 0) decrementSnapshot, snd, Just TooOldSnapshot)
]

let decrementAction = produceDecrement ctx scriptRegistry headId' parameters
let closeAction = produceClose ctx scriptRegistry headId' parameters
-- let contestAction = produceContest ctx scriptRegistry headId'
-- let fanoutAction = produceFanout ctx headTxIn

fst $ flip runState spendableUTxO $ do
mapM_
( \(decrementSn, _, expectedDecrementErr) -> do
decrementAction decrementSn expectedDecrementErr
)
decrementSnapshots
let contestSnapshots =
[ (mutateSnapshotNumber (+ 1) decrementSnapshot, createCloseDatumFromOpen, Nothing)
]

mapM_
( \(closeSn, _, expectedCloseErr) -> do
closeAction closeSn expectedCloseErr
)
closeSnapshots
flip evalState spendableUTxO $ do
decrementResults <- mapM (produceDecrement ctx headId' parameters) decrementSnapshots
closeResults <- mapM (produceClose ctx headId' parameters) closeSnapshots
contestResults <- mapM (produceContest ctx headId') contestSnapshots
pure $
conjoin $
( \case
Left err -> counterexample err $ property False
Right (tx, utxo, mHeadError) ->
evaluateAndMatchError tx utxo mHeadError
)
<$> (decrementResults <> closeResults <> contestResults)

mutateSnapshotNumber :: (SnapshotNumber -> SnapshotNumber) -> Snapshot Tx -> Snapshot Tx
mutateSnapshotNumber fn snapshot =
Expand All @@ -312,41 +335,36 @@ mutateUTxOToDecommit fn snapshot =
let toDecommit = fn (utxoToDecommit snapshot)
in snapshot{utxoToDecommit = toDecommit}

produceDecrement :: ChainContext -> ScriptRegistry -> HeadId -> HeadParameters -> Snapshot Tx -> Maybe HeadError -> State UTxO Property
produceDecrement ctx scriptRegistry headId parameters snapshot expectedError = do
produceDecrement :: ChainContext -> HeadId -> HeadParameters -> (Snapshot Tx, (Snapshot Tx, UTxO) -> UTxO, Maybe HeadError) -> State UTxO (Either String (Tx, UTxO, Maybe HeadError))
produceDecrement ctx headId parameters (snapshot, mutateSpendableUTxO, expectedError) = do
spendableUTxO <- get
let decommitValue = foldMap (txOutValue . snd) (UTxO.pairs $ fromMaybe mempty $ utxoToDecommit snapshot)
case decrement ctx headId parameters spendableUTxO snapshot signatures of
Left err -> pure (counterexample ("Decrement tx:" <> show err) $ property False)
let newSpendableUTxO = mutateSpendableUTxO (snapshot, spendableUTxO)
case decrement ctx headId parameters newSpendableUTxO snapshot signatures of
Left err -> pure $ Left $ show err
Right tx -> do
let spendableUTxO' =
foldMap (\(txin, txout) -> UTxO.singleton (txin, modifyTxOutValue (<> decommitValue) txout)) (UTxO.pairs (utxoFromTx tx))
<> registryUTxO scriptRegistry
put spendableUTxO'
pure $ evaluateAndMatchError tx spendableUTxO' expectedError
pure $ Right (tx, newSpendableUTxO, expectedError)
where
signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]

produceClose :: ChainContext -> ScriptRegistry -> HeadId -> HeadParameters -> Snapshot Tx -> Maybe HeadError -> State UTxO Property
produceClose ctx scriptRegistry headId parameters snapshot expectedError = do
produceClose :: ChainContext -> HeadId -> HeadParameters -> (Snapshot Tx, (Snapshot Tx, UTxO) -> UTxO, Maybe HeadError) -> State UTxO (Either String (Tx, UTxO, Maybe HeadError))
produceClose ctx headId parameters (snapshot, mutateSpendableUTxO, expectedError) = do
spendableUTxO <- get
case close ctx spendableUTxO headId parameters ConfirmedSnapshot{snapshot, signatures} 0 (0, posixSecondsToUTCTime 0) of
Left err -> pure (counterexample ("Close tx: " <> show err) $ property False)
let newSpendableUTxO = mutateSpendableUTxO (snapshot, spendableUTxO)
case close ctx newSpendableUTxO headId parameters ConfirmedSnapshot{snapshot, signatures} 0 (0, posixSecondsToUTCTime 0) of
Left err -> pure $ Left (show err)
Right tx -> do
let spendableUTxO' = utxoFromTx tx <> registryUTxO scriptRegistry
put spendableUTxO'
pure $ evaluateAndMatchError tx spendableUTxO' expectedError
pure $ Right (tx, newSpendableUTxO, expectedError)
where
signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]

produceContest :: ChainContext -> ScriptRegistry -> HeadId -> Snapshot Tx -> State UTxO (Either String Tx)
produceContest ctx scriptRegistry headId snapshot = do
produceContest :: ChainContext -> HeadId -> (Snapshot Tx, (Snapshot Tx, UTxO) -> UTxO, Maybe HeadError) -> State UTxO (Either String (Tx, UTxO, Maybe HeadError))
produceContest ctx headId (snapshot, mutateSpendableUTxO, expectedError) = do
spendableUTxO <- get
case contest ctx spendableUTxO headId (UnsafeContestationPeriod 0) ConfirmedSnapshot{snapshot, signatures} (0, posixSecondsToUTCTime 0) of
Left err -> pure (Left $ "Contest tx: " <> show err)
let newSpendableUTxO = mutateSpendableUTxO (snapshot, spendableUTxO)
case contest ctx newSpendableUTxO headId (UnsafeContestationPeriod 0) ConfirmedSnapshot{snapshot, signatures} (0, posixSecondsToUTCTime 0) of
Left err -> pure $ Left $ show err
Right tx -> do
put $ utxoFromTx tx <> registryUTxO scriptRegistry
pure $ Right tx
pure $ Right (tx, newSpendableUTxO, expectedError)
where
signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]

Expand Down

0 comments on commit f9f190e

Please sign in to comment.