{-# LANGUAGE DuplicateRecordFields #-}

-- | End-to-end regression tests for the deposit-stealing class of bugs.
module Hydra.Cluster.SecurityScenarios where

import Hydra.Prelude
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import CardanoClient (
  QueryPoint (QueryTip),
 )
import CardanoNode (EndToEndLog (..), runBackend)
import Control.Lens ((^?))
import Data.Aeson.Lens (key)
import Data.Aeson.Types (parseMaybe)
import Data.Set qualified as Set
import Hydra.Cardano.Api (
  AssetId (AssetId),
  Coin (..),
  LedgerProtocolParameters (..),
  Quantity (..),
  TxId,
  addTxExtraKeyWits,
  addTxIns,
  addTxInsCollateral,
  addTxOuts,
  chainPointToSlotNo,
  defaultTxBodyContent,
  fromCtxUTxOTxOut,
  fromScriptData,
  lovelaceToValue,
  mkScriptAddress,
  mkScriptWitness,
  mkTxOutDatumInline,
  mkVkAddress,
  modifyTxOutDatum,
  modifyTxOutValue,
  scriptPolicyId,
  scriptWitnessInCtx,
  selectLovelace,
  setTxProtocolParams,
  setTxValidityLowerBound,
  setTxValidityUpperBound,
  signTx,
  toPlutusTxOutRef,
  toScriptData,
  toShelleyNetwork,
  txOutScriptData,
  txOutValue,
  verificationKeyHash,
  pattern BuildTxWith,
  pattern InlineScriptDatum,
  pattern KeyWitness,
  pattern KeyWitnessForSpending,
  pattern PlutusScript,
  pattern ReferenceScriptNone,
  pattern ScriptWitness,
  pattern ShelleyAddressInEra,
  pattern TxOut,
  pattern TxOutDatumNone,
  pattern TxValidityLowerBound,
  pattern TxValidityUpperBound,
 )
import Hydra.Cardano.Api qualified as CAPI
import Hydra.Chain.Backend (ChainBackend (..), buildTransactionWithBody)
import Hydra.Chain.Direct.TimeHandle (TimeHandle (..), mkTimeHandle)
import Hydra.Cluster.Faucet (seedFromFaucet, seedFromFaucetWithMinting)
import Hydra.Cluster.Fixture (Actor (..), alice, aliceSk)
import Hydra.Cluster.Scenarios (
  headIsOpenWith,
  refuelIfNeeded,
  returnFundsToFaucet,
 )
import Hydra.Cluster.Util (Timing, chainConfigFor, depositTimeout, keysFor, mkTestTiming, setNetworkId)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Contract.DepositError (DepositError (..))
import Hydra.Contract.Dummy (dummyMintingScript)
import Hydra.Contract.Error (toErrorCode)
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState (
  CloseRedeemer (CloseInitial),
  ClosedDatum (ClosedDatum),
  IncrementRedeemer (IncrementRedeemer),
  Input (Close, Increment),
  OpenDatum (OpenDatum),
  State (Closed, Open),
 )
import Hydra.Contract.HeadState qualified as Head
import Hydra.Data.ContestationPeriod (addContestationPeriod)
import Hydra.Logging (Tracer)
import Hydra.Options (ChainBackendOptions (..))
import Hydra.Plutus (depositValidatorScript)
import Hydra.Plutus.Extras.Time (posixFromUTCTime)
import Hydra.Tx (HeadId, IsTx (balance, hashUTxO), headIdToCurrencySymbol, headIdToPolicyId, txId)
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.Crypto (aggregate, sign, toPlutusSignatures)
import Hydra.Tx.Snapshot (Snapshot (Snapshot))
import Hydra.Tx.Snapshot qualified as Snapshot
import Hydra.Tx.Utils (hydraHeadV2AssetName)
import HydraNode (
  HydraClient,
  input,
  requestCommitTx,
  send,
  waitMatch,
  withSoloHydraNode,
 )
import PlutusLedgerApi.V3 (toBuiltin)
import Test.Hydra.Tx.Gen (genKeyPair)
import Test.QuickCheck (generate)

-- * Standalone Claim with no head input

-- | Regression test for the standalone-Claim deposit-stealing attack.
--
-- A third party submits a standalone tx that spends a pending deposit UTxO
-- with the @Claim@ redeemer, redirecting the value to their own address.
-- The tx has no Head input at all, so the deposit validator's @Claim@
-- branch fails on @list.find@ with @DepositHeadInputNotFound@ (D06).
cannotStealDepositWithoutHeadInput ::
  Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
cannotStealDepositWithoutHeadInput :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
cannotStealDepositWithoutHeadInput Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId =
  (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
30_000_000
    NominalDiffTime
blockTime <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NominalDiffTime)
-> IO NominalDiffTime
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NominalDiffTime
getBlockTime
    let timing :: Timing
timing = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
    NetworkId
networkId <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NetworkId)
-> IO NetworkId
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NetworkId
queryNetworkId
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [] Timing
timing
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId
    let hydraTracer :: Tracer IO HydraNodeLog
hydraTracer = (HydraNodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO HydraNodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog -> EndToEndLog
FromHydraNode Tracer IO EndToEndLog
tracer
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
      HeadId
_headId <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsOpenWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

      (VerificationKey PaymentKey
victimVk, TxId
depositTxId') <- Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> Timing
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDeposit Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 Timing
timing SnapshotVersion
5_000_000

      -- Kate: independent attacker wallet, funded for fees + collateral.
      (VerificationKey PaymentKey
kateVk, SigningKey PaymentKey
kateSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
      let kateFunds :: SnapshotVersion
kateFunds = SnapshotVersion
30_000_000 :: Integer
      UTxO
kateFundsUTxO <-
        ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
kateVk (Lovelace -> Value
lovelaceToValue (SnapshotVersion -> Lovelace
forall a. Num a => SnapshotVersion -> a
fromInteger SnapshotVersion
kateFunds)) ((FaucetLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO FaucetLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap FaucetLog -> EndToEndLog
FromFaucet Tracer IO EndToEndLog
tracer)

      UTxO
depositUTxO <-
        ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m UTxO)
 -> IO UTxO)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a b. (a -> b) -> a -> b
$ [TxIn] -> m UTxO
forall (m :: * -> *). ChainBackend m => [TxIn] -> m UTxO
queryUTxOByTxIn [TxId -> TxIx -> TxIn
CAPI.TxIn TxId
depositTxId' (Word -> TxIx
CAPI.TxIx Word
0)]
      (TxIn
depositTxIn, TxOut CtxUTxO
depositTxOut) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"deposit UTxO" UTxO
depositUTxO
      (TxIn
kateTxIn, TxOut CtxUTxO
_) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"Kate funding UTxO" UTxO
kateFundsUTxO

      let kateAddr :: AddressInEra Era
kateAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
kateVk
          stolenValue :: Value
stolenValue = TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
depositTxOut
          stealOutput :: TxOut CtxTx
stealOutput = AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra Era
kateAddr Value
stolenValue TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone
          extraInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs =
            [(TxIn
kateTxIn, Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)]

      AttemptArgs -> IO ()
attemptStealAndAssertRejected
        AttemptArgs
          { Tracer IO EndToEndLog
tracer :: Tracer IO EndToEndLog
$sel:tracer:AttemptArgs :: Tracer IO EndToEndLog
tracer
          , ChainBackendOptions
opts :: ChainBackendOptions
$sel:opts:AttemptArgs :: ChainBackendOptions
opts
          , TxIn
depositTxIn :: TxIn
$sel:depositTxIn:AttemptArgs :: TxIn
depositTxIn
          , $sel:depositTxOuts:AttemptArgs :: [(TxIn, TxOut CtxUTxO)]
depositTxOuts = [(TxIn
depositTxIn, TxOut CtxUTxO
depositTxOut)]
          , [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
$sel:extraInputs:AttemptArgs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs
          , $sel:collateralIn:AttemptArgs :: TxIn
collateralIn = TxIn
kateTxIn
          , $sel:extraOutputs:AttemptArgs :: [TxOut CtxTx]
extraOutputs = [TxOut CtxTx
stealOutput]
          , $sel:attackerSk:AttemptArgs :: SigningKey PaymentKey
attackerSk = SigningKey PaymentKey
kateSk
          , $sel:attackerAddr:AttemptArgs :: AddressInEra Era
attackerAddr = AddressInEra Era
kateAddr
          , $sel:spendable:AttemptArgs :: UTxO
spendable = UTxO
depositUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
kateFundsUTxO
          , -- No head input is consumed at all, so the deposit's Claim
            -- branch fails on @list.find@ with @DepositHeadInputNotFound@.
            $sel:expectedTrace:AttemptArgs :: String
expectedTrace = Text -> String
forall a. ToString a => a -> String
toString (DepositError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode DepositError
DepositHeadInputNotFound)
          }

      ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
depositTxId' Value
stolenValue
      ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
victimVk SnapshotVersion
0
      ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
kateVk SnapshotVersion
kateFunds

-- * Counterfeit Head state-token

-- | The attacker mints a counterfeit token of asset name @HydraHeadV2@
-- under a permissive minting policy they control, locks it in their own
-- wallet, and uses that UTxO as bait alongside a victim deposit. The
-- deposit validator's @Claim@ branch searches the inputs for a UTxO that
-- carries the real head's policy id; the counterfeit token's policy id
-- does not match, so the validator fails with
-- @DepositHeadInputNotFound@ (D06).
cannotStealDepositWithCounterfeitHeadToken ::
  Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
cannotStealDepositWithCounterfeitHeadToken :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
cannotStealDepositWithCounterfeitHeadToken Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId =
  (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
30_000_000
    NominalDiffTime
blockTime <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NominalDiffTime)
-> IO NominalDiffTime
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NominalDiffTime
getBlockTime
    let timing :: Timing
timing = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
    NetworkId
networkId <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NetworkId)
-> IO NetworkId
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NetworkId
queryNetworkId
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [] Timing
timing
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId
    let hydraTracer :: Tracer IO HydraNodeLog
hydraTracer = (HydraNodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO HydraNodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog -> EndToEndLog
FromHydraNode Tracer IO EndToEndLog
tracer
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
      HeadId
_headId <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsOpenWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

      (VerificationKey PaymentKey
victimVk, TxId
depositTxId') <- Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> Timing
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDeposit Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 Timing
timing SnapshotVersion
5_000_000

      -- Kate mints a counterfeit (mu_attack, "HydraHeadV2") token under
      -- a permissive minting policy and locks it (alongside enough ada for
      -- fees + collateral) in her own wallet. mu_attack is the policy id
      -- of dummyMintingScript and is *not* the policy id of any real Hydra
      -- head -- those are parameterised by a unique seed input.
      (VerificationKey PaymentKey
kateVk, SigningKey PaymentKey
kateSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
      let kateFunds :: SnapshotVersion
kateFunds = SnapshotVersion
30_000_000 :: Integer
          attackPolicyId :: PolicyId
attackPolicyId = Script PlutusScriptV3 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (PlutusScript -> Script PlutusScriptV3
PlutusScript PlutusScript
dummyMintingScript)
          counterfeitToken :: AssetId
counterfeitToken = PolicyId -> AssetName -> AssetId
AssetId PolicyId
attackPolicyId AssetName
hydraHeadV2AssetName
          counterfeitValue :: Value
counterfeitValue =
            Lovelace -> Value
lovelaceToValue (SnapshotVersion -> Lovelace
forall a. Num a => SnapshotVersion -> a
fromInteger SnapshotVersion
kateFunds)
              Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [Item Value] -> Value
forall l. IsList l => [Item l] -> l
fromList [(AssetId
counterfeitToken, SnapshotVersion -> Quantity
Quantity SnapshotVersion
1)]
      UTxO
kateUTxO <-
        ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> Maybe PlutusScript
-> IO UTxO
seedFromFaucetWithMinting
          ChainBackendOptions
opts
          VerificationKey PaymentKey
kateVk
          Value
counterfeitValue
          ((FaucetLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO FaucetLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap FaucetLog -> EndToEndLog
FromFaucet Tracer IO EndToEndLog
tracer)
          (PlutusScript -> Maybe PlutusScript
forall a. a -> Maybe a
Just PlutusScript
dummyMintingScript)

      UTxO
depositUTxO <-
        ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m UTxO)
 -> IO UTxO)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a b. (a -> b) -> a -> b
$ [TxIn] -> m UTxO
forall (m :: * -> *). ChainBackend m => [TxIn] -> m UTxO
queryUTxOByTxIn [TxId -> TxIx -> TxIn
CAPI.TxIn TxId
depositTxId' (Word -> TxIx
CAPI.TxIx Word
0)]
      (TxIn
depositTxIn, TxOut CtxUTxO
depositTxOut) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"deposit UTxO" UTxO
depositUTxO
      (TxIn
kateTxIn, TxOut CtxUTxO
_) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"Kate bait UTxO" UTxO
kateUTxO

      let kateAddr :: AddressInEra Era
kateAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
kateVk
          stolenValue :: Value
stolenValue = TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
depositTxOut
          stealOutput :: TxOut CtxTx
stealOutput = AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra Era
kateAddr Value
stolenValue TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone

      AttemptArgs -> IO ()
attemptStealAndAssertRejected
        AttemptArgs
          { Tracer IO EndToEndLog
$sel:tracer:AttemptArgs :: Tracer IO EndToEndLog
tracer :: Tracer IO EndToEndLog
tracer
          , ChainBackendOptions
$sel:opts:AttemptArgs :: ChainBackendOptions
opts :: ChainBackendOptions
opts
          , TxIn
$sel:depositTxIn:AttemptArgs :: TxIn
depositTxIn :: TxIn
depositTxIn
          , $sel:depositTxOuts:AttemptArgs :: [(TxIn, TxOut CtxUTxO)]
depositTxOuts = [(TxIn
depositTxIn, TxOut CtxUTxO
depositTxOut)]
          , $sel:extraInputs:AttemptArgs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs =
              [(TxIn
kateTxIn, Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)]
          , $sel:collateralIn:AttemptArgs :: TxIn
collateralIn = TxIn
kateTxIn
          , $sel:extraOutputs:AttemptArgs :: [TxOut CtxTx]
extraOutputs = [TxOut CtxTx
stealOutput]
          , $sel:attackerSk:AttemptArgs :: SigningKey PaymentKey
attackerSk = SigningKey PaymentKey
kateSk
          , $sel:attackerAddr:AttemptArgs :: AddressInEra Era
attackerAddr = AddressInEra Era
kateAddr
          , $sel:spendable:AttemptArgs :: UTxO
spendable = UTxO
depositUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
kateUTxO
          , -- The counterfeit token's policy id does not match the real
            -- head's policy id, so @list.find@ in the deposit Claim branch
            -- fails to identify any head input.
            $sel:expectedTrace:AttemptArgs :: String
expectedTrace = Text -> String
forall a. ToString a => a -> String
toString (DepositError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode DepositError
DepositHeadInputNotFound)
          }

      ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
depositTxId' Value
stolenValue
      ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
victimVk SnapshotVersion
0
      -- Kate's UTxO is unchanged; her ada balance is still her seed.
      ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
kateVk SnapshotVersion
kateFunds

-- * Helpers

-- | Place a deposit of `amount` lovelace from a fresh wallet into the head
-- managed by @n1@. Returns the wallet's verification key (so its balance
-- can be queried later) and the deposit transaction id.
placeVictimDeposit ::
  Tracer IO EndToEndLog ->
  ChainBackendOptions ->
  HydraClient ->
  Timing ->
  Integer ->
  IO (CAPI.VerificationKey CAPI.PaymentKey, TxId)
placeVictimDeposit :: Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> Timing
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDeposit Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 Timing
timing SnapshotVersion
amount = do
  (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
  UTxO
utxo <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
vk (Lovelace -> Value
lovelaceToValue (SnapshotVersion -> Lovelace
forall a. Num a => SnapshotVersion -> a
fromInteger SnapshotVersion
amount)) ((FaucetLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO FaucetLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap FaucetLog -> EndToEndLog
FromFaucet Tracer IO EndToEndLog
tracer)
  Tx Era
depositTx <- HydraClient -> UTxO -> IO (Tx Era)
requestCommitTx HydraClient
n1 UTxO
utxo IO (Tx Era) -> (Tx Era -> Tx Era) -> IO (Tx Era)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx Era -> Tx Era
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
sk
  ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m ())
 -> IO ())
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ Tx Era -> m ()
forall (m :: * -> *). ChainBackend m => Tx Era -> m ()
submitTransaction Tx Era
depositTx
  UTCTime
_ :: UTCTime <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (Timing -> NominalDiffTime
depositTimeout Timing
timing) HydraClient
n1 ((Value -> Maybe UTCTime) -> IO UTCTime)
-> (Value -> Maybe UTCTime) -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"tag" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
"CommitRecorded"
    Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"deadline" Maybe Value -> (Value -> Maybe UTCTime) -> Maybe UTCTime
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser UTCTime) -> Value -> Maybe UTCTime
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser UTCTime
forall a. FromJSON a => Value -> Parser a
parseJSON
  (VerificationKey PaymentKey, TxId)
-> IO (VerificationKey PaymentKey, TxId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationKey PaymentKey
vk, Tx Era -> TxIdType (Tx Era)
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx Era
depositTx)

-- | Encapsulates the moving parts of an attempted-steal transaction.
data AttemptArgs = AttemptArgs
  { AttemptArgs -> Tracer IO EndToEndLog
tracer :: Tracer IO EndToEndLog
  , AttemptArgs -> ChainBackendOptions
opts :: ChainBackendOptions
  , AttemptArgs -> TxIn
depositTxIn :: CAPI.TxIn
  -- ^ Diagnostic / naming hook for the "primary" deposit being attacked.
  , AttemptArgs -> [(TxIn, TxOut CtxUTxO)]
depositTxOuts :: [(CAPI.TxIn, CAPI.TxOut CAPI.CtxUTxO)]
  -- ^ Deposit-script UTxOs being attacked. The first entry is wired up
  -- as a Claim-witnessed input by the helper; additional deposit inputs
  -- (for amplification cases) must be passed through 'extraInputs' with
  -- their own deposit-script witness.
  -- TODO: This may not need to be alist, and should be more simply a "UTxO"
  -- type.
  , AttemptArgs -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs :: [(CAPI.TxIn, CAPI.BuildTxWith CAPI.BuildTx (CAPI.Witness CAPI.WitCtxTxIn))]
  -- ^ Additional non-deposit-script inputs (key witnesses or extra deposit
  -- script witnesses for amplification cases).
  , AttemptArgs -> TxIn
collateralIn :: CAPI.TxIn
  , AttemptArgs -> [TxOut CtxTx]
extraOutputs :: [CAPI.TxOut CAPI.CtxTx]
  , AttemptArgs -> SigningKey PaymentKey
attackerSk :: CAPI.SigningKey CAPI.PaymentKey
  , AttemptArgs -> AddressInEra Era
attackerAddr :: CAPI.AddressInEra
  , AttemptArgs -> UTxO
spendable :: CAPI.UTxO
  , AttemptArgs -> String
expectedTrace :: String
  -- ^ Plutus error trace (e.g. @"D06"@) expected on the autobalancer's
  -- 'Left'. The build error must contain this trace; any other 'Left'
  -- (insufficient ada for fees, integrity-hash mismatch, era hiccup, ...)
  -- is treated as a test failure rather than success.
  }

-- | Build a steal transaction and assert the autobalancer rejects it
-- specifically because the deposit validator failed with
-- 'AttemptArgs.expectedTrace'. Any other 'Left' (insufficient ada,
-- integrity hash mismatch, era issue, ...) is treated as a test failure.
attemptStealAndAssertRejected :: AttemptArgs -> IO ()
attemptStealAndAssertRejected :: AttemptArgs -> IO ()
attemptStealAndAssertRejected
  AttemptArgs
    { ChainBackendOptions
$sel:opts:AttemptArgs :: AttemptArgs -> ChainBackendOptions
opts :: ChainBackendOptions
opts
    , [(TxIn, TxOut CtxUTxO)]
$sel:depositTxOuts:AttemptArgs :: AttemptArgs -> [(TxIn, TxOut CtxUTxO)]
depositTxOuts :: [(TxIn, TxOut CtxUTxO)]
depositTxOuts
    , [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
$sel:extraInputs:AttemptArgs :: AttemptArgs -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs
    , TxIn
$sel:collateralIn:AttemptArgs :: AttemptArgs -> TxIn
collateralIn :: TxIn
collateralIn
    , [TxOut CtxTx]
$sel:extraOutputs:AttemptArgs :: AttemptArgs -> [TxOut CtxTx]
extraOutputs :: [TxOut CtxTx]
extraOutputs
    , $sel:attackerSk:AttemptArgs :: AttemptArgs -> SigningKey PaymentKey
attackerSk = SigningKey PaymentKey
_
    , AddressInEra Era
$sel:attackerAddr:AttemptArgs :: AttemptArgs -> AddressInEra Era
attackerAddr :: AddressInEra Era
attackerAddr
    , UTxO
$sel:spendable:AttemptArgs :: AttemptArgs -> UTxO
spendable :: UTxO
spendable
    , String
$sel:expectedTrace:AttemptArgs :: AttemptArgs -> String
expectedTrace :: String
expectedTrace
    } = do
    let claimRedeemer :: HashableScriptData
claimRedeemer = Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData) -> Redeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ DepositRedeemer -> Redeemer
Deposit.redeemer DepositRedeemer
Deposit.Claim
        depositWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness =
          Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
            ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
depositValidatorScript ScriptDatum WitCtxTxIn
CAPI.InlineScriptDatum HashableScriptData
claimRedeemer
        firstDepositInput :: (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
firstDepositInput =
          case [(TxIn, TxOut CtxUTxO)]
depositTxOuts of
            ((TxIn
i, TxOut CtxUTxO
_) : [(TxIn, TxOut CtxUTxO)]
_) -> (TxIn
i, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)
            [] -> Text -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"attemptStealAndAssertRejected: no deposit inputs"

    PParams ConwayEra
pparams <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (PParams ConwayEra))
 -> IO (PParams ConwayEra))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters QueryPoint
QueryTip
    SystemStart
systemStart <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m SystemStart)
 -> IO SystemStart)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
QueryTip
    EraHistory
eraHistory <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m EraHistory)
 -> IO EraHistory)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip
    Set PoolId
stakePools <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (Set PoolId))
 -> IO (Set PoolId))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (Set PoolId)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (Set PoolId)
queryStakePools QueryPoint
QueryTip
    ChainPoint
tip <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ChainPoint)
-> IO ChainPoint
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m ChainPoint
queryTip
    let tipSlot :: SlotNo
tipSlot = SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
tip)
        -- Validity bound well before the (~3 * 20 * blockTime) deadline.
        -- With default test timing (blockTime = 1s), deadline is ~60s out;
        -- 30 slots is comfortably inside that window.
        upperSlot :: SlotNo
upperSlot = SlotNo
tipSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
30

    let body :: TxBodyContent BuildTx Era
body =
          TxBodyContent BuildTx Era
defaultTxBodyContent
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns ((TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
firstDepositInput (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
forall a. a -> [a] -> [a]
: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
extraInputs)
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [TxOut CtxTx]
extraOutputs
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsCollateral [TxIn
collateralIn]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& TxValidityUpperBound Era
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
TxValidityUpperBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityUpperBound (SlotNo -> TxValidityUpperBound Era
TxValidityUpperBound SlotNo
upperSlot)
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
BuildTxWith build (Maybe (LedgerProtocolParameters era))
-> TxBodyContent build era -> TxBodyContent build era
setTxProtocolParams (Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters Era)
 -> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era)))
-> Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a. a -> Maybe a
Just (LedgerProtocolParameters Era
 -> Maybe (LedgerProtocolParameters Era))
-> LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
PParams ConwayEra
pparams)

    case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra Era
-> TxBodyContent BuildTx Era
-> UTxO
-> Either (TxBodyErrorAutoBalance Era) (Tx Era)
buildTransactionWithBody PParams LedgerEra
PParams ConwayEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra Era
attackerAddr TxBodyContent BuildTx Era
body UTxO
spendable of
      Left TxBodyErrorAutoBalance Era
e -> TxBodyErrorAutoBalance Era -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyErrorAutoBalance Era
e String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` String
expectedTrace
      Right Tx Era
_ ->
        Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected script evaluation to reject the steal tx, but the build succeeded"

requireSingletonUTxO ::
  HasCallStack =>
  String ->
  CAPI.UTxO ->
  IO (CAPI.TxIn, CAPI.TxOut CAPI.CtxUTxO)
requireSingletonUTxO :: HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
description UTxO
utxo =
  case UTxO -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
utxo of
    [(TxIn
i, TxOut CtxUTxO
o)] -> (TxIn, TxOut CtxUTxO) -> IO (TxIn, TxOut CtxUTxO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn
i, TxOut CtxUTxO
o)
    [(TxIn, TxOut CtxUTxO)]
xs -> String -> IO (TxIn, TxOut CtxUTxO)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO (TxIn, TxOut CtxUTxO))
-> String -> IO (TxIn, TxOut CtxUTxO)
forall a b. (a -> b) -> a -> b
$ String
"expected exactly one " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
description String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([(TxIn, TxOut CtxUTxO)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxIn, TxOut CtxUTxO)]
xs)

assertDepositStillLocked ::
  ChainBackendOptions -> TxId -> CAPI.Value -> IO ()
assertDepositStillLocked :: ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
depositTxId' Value
expectedValue = do
  UTxOType (Tx Era)
utxo <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxOType (Tx Era)))
-> IO (UTxOType (Tx Era))
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (UTxOType (Tx Era)))
 -> IO (UTxOType (Tx Era)))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxOType (Tx Era)))
-> IO (UTxOType (Tx Era))
forall a b. (a -> b) -> a -> b
$ [TxIn] -> m UTxO
forall (m :: * -> *). ChainBackend m => [TxIn] -> m UTxO
queryUTxOByTxIn [TxId -> TxIx -> TxIn
CAPI.TxIn TxId
depositTxId' (Word -> TxIx
CAPI.TxIx Word
0)]
  Value -> Lovelace
selectLovelace (UTxOType (Tx Era) -> ValueType (Tx Era)
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance UTxOType (Tx Era)
utxo) Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Value -> Lovelace
selectLovelace Value
expectedValue

assertWalletLovelace ::
  ChainBackendOptions -> CAPI.VerificationKey CAPI.PaymentKey -> Integer -> IO ()
assertWalletLovelace :: ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
vk SnapshotVersion
expected =
  (Value -> Lovelace
selectLovelace (Value -> Lovelace)
-> (UTxOType (Tx Era) -> Value) -> UTxOType (Tx Era) -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxOType (Tx Era) -> Value
UTxOType (Tx Era) -> ValueType (Tx Era)
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType (Tx Era) -> Lovelace)
-> IO (UTxOType (Tx Era)) -> IO Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (UTxOType (Tx Era)))
-> IO (UTxOType (Tx Era))
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts (QueryPoint -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> VerificationKey PaymentKey -> m UTxO
queryUTxOFor QueryPoint
QueryTip VerificationKey PaymentKey
vk))
    IO Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` SnapshotVersion -> Lovelace
Coin SnapshotVersion
expected

-- * Multi-deposit redirection during a real Increment

-- | A malicious participant of a head constructs an Increment-shaped
-- transaction that consumes the head's ST + the redeemer-specified
-- deposit + ANOTHER pending deposit for the same head, and routes the
-- extra deposit's value to attacker-controlled outputs.
--
-- Setup: 1-party head (Alice). Two unrelated depositors (V1 and V2) each
-- deposit funds for Alice's head. Alice (the malicious participant)
-- constructs an Increment that claims V1's deposit (which is in the
-- snapshot Alice signs) but ALSO consumes V2's deposit and routes its
-- value to a Kate address. V2's deposit rejects a Claim that the head's
-- Increment redeemer does not name (@DepositNotClaimedByHead@, D09).
--
-- That is the only rule rejecting this: the head validator grows by exactly the
-- deposit its redeemer names, so V2's value escaping to Kate leaves
-- @mustPreserveValue@ satisfied.
cannotRedirectExtraDepositDuringIncrement ::
  Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
cannotRedirectExtraDepositDuringIncrement :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
cannotRedirectExtraDepositDuringIncrement Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId =
  (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
60_000_000
    NominalDiffTime
blockTime <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NominalDiffTime)
-> IO NominalDiffTime
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NominalDiffTime
getBlockTime
    let timing :: Timing
timing = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
    NetworkId
networkId <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NetworkId)
-> IO NetworkId
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NetworkId
queryNetworkId
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [] Timing
timing
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId
    let hydraTracer :: Tracer IO HydraNodeLog
hydraTracer = (HydraNodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO HydraNodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog -> EndToEndLog
FromHydraNode Tracer IO EndToEndLog
tracer

    -- Use the hydra-node only to bootstrap the head and produce the two
    -- deposit txs. We exit the bracket immediately after submitting the
    -- deposits (without waiting for CommitRecorded), so the node does not
    -- get a chance to submit its own honest Increment that would race the
    -- redirection.
    (HeadId
headId, VerificationKey PaymentKey
victim1Vk, TxId
deposit1TxId, VerificationKey PaymentKey
victim2Vk, TxId
deposit2TxId) <-
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient
    -> IO
         (HeadId, VerificationKey PaymentKey, TxId,
          VerificationKey PaymentKey, TxId))
-> IO
     (HeadId, VerificationKey PaymentKey, TxId,
      VerificationKey PaymentKey, TxId)
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient
  -> IO
       (HeadId, VerificationKey PaymentKey, TxId,
        VerificationKey PaymentKey, TxId))
 -> IO
      (HeadId, VerificationKey PaymentKey, TxId,
       VerificationKey PaymentKey, TxId))
-> (HydraClient
    -> IO
         (HeadId, VerificationKey PaymentKey, TxId,
          VerificationKey PaymentKey, TxId))
-> IO
     (HeadId, VerificationKey PaymentKey, TxId,
      VerificationKey PaymentKey, TxId)
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
        HeadId
hid <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsOpenWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])
        (VerificationKey PaymentKey
vVk1, TxId
dTxId1) <- Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDepositNoWait Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 SnapshotVersion
5_000_000
        (VerificationKey PaymentKey
vVk2, TxId
dTxId2) <- Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDepositNoWait Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 SnapshotVersion
7_000_000
        (HeadId, VerificationKey PaymentKey, TxId,
 VerificationKey PaymentKey, TxId)
-> IO
     (HeadId, VerificationKey PaymentKey, TxId,
      VerificationKey PaymentKey, TxId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
hid, VerificationKey PaymentKey
vVk1, TxId
dTxId1, VerificationKey PaymentKey
vVk2, TxId
dTxId2)

    -- Wait for the deposit script UTxOs to land on chain.
    UTxO
deposit1UTxO <- ChainBackendOptions -> TxIn -> IO UTxO
waitForOnChainUTxO ChainBackendOptions
opts (TxId -> TxIx -> TxIn
CAPI.TxIn TxId
deposit1TxId (Word -> TxIx
CAPI.TxIx Word
0))
    UTxO
deposit2UTxO <- ChainBackendOptions -> TxIn -> IO UTxO
waitForOnChainUTxO ChainBackendOptions
opts (TxId -> TxIx -> TxIn
CAPI.TxIn TxId
deposit2TxId (Word -> TxIx
CAPI.TxIx Word
0))
    (TxIn
deposit1In, TxOut CtxUTxO
deposit1Out) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"deposit 1 UTxO" UTxO
deposit1UTxO
    (TxIn
deposit2In, TxOut CtxUTxO
deposit2Out) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"deposit 2 UTxO" UTxO
deposit2UTxO

    -- Fee/collateral wallet for Alice's malicious tx (using AliceFunds —
    -- separate from the participation key used for the head's
    -- mustBeSignedByParticipant check).
    (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_aliceCardanoSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice
    (VerificationKey PaymentKey
aliceFundsVk, Secret (SigningKey PaymentKey)
_aliceFundsSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
AliceFunds
    UTxO
aliceFundsUTxO <-
      ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet
        ChainBackendOptions
opts
        VerificationKey PaymentKey
aliceFundsVk
        (Lovelace -> Value
lovelaceToValue Lovelace
30_000_000)
        ((FaucetLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO FaucetLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap FaucetLog -> EndToEndLog
FromFaucet Tracer IO EndToEndLog
tracer)
    (TxIn
aliceFundsIn, TxOut CtxUTxO
_) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"Alice funds" UTxO
aliceFundsUTxO

    -- Kate is the recipient of the redirected funds — could be Alice
    -- herself; using a fresh wallet just to make the post-attack assertion
    -- crisp ("Kate had nothing before; if she has D2's value after, the
    -- attack succeeded").
    (VerificationKey PaymentKey
kateVk, SigningKey PaymentKey
_) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
    let kateAddr :: AddressInEra Era
kateAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
kateVk

    -- Locate the head's continuation UTxO and read its OpenDatum.
    (TxIn
headIn, TxOut CtxUTxO
headOut, OpenDatum
prevOpenDatum) <-
      ChainBackendOptions
-> NetworkId -> HeadId -> IO (TxIn, TxOut CtxUTxO, OpenDatum)
findHeadContinuationUTxO ChainBackendOptions
opts NetworkId
networkId HeadId
headId
    let OpenDatum
          { $sel:headSeed:OpenDatum :: OpenDatum -> TxOutRef
Head.headSeed = TxOutRef
prevHeadSeed
          , $sel:parties:OpenDatum :: OpenDatum -> [Party]
Head.parties = [Party]
prevParties
          , $sel:contestationPeriod:OpenDatum :: OpenDatum -> ContestationPeriod
Head.contestationPeriod = ContestationPeriod
prevPeriod
          , $sel:depositPeriod:OpenDatum :: OpenDatum -> DepositPeriod
Head.depositPeriod = DepositPeriod
prevDepositPeriod
          , $sel:version:OpenDatum :: OpenDatum -> SnapshotVersion
Head.version = SnapshotVersion
prevVersion
          , $sel:headAdaOverhead:OpenDatum :: OpenDatum -> SnapshotVersion
Head.headAdaOverhead = SnapshotVersion
prevHeadAdaOverhead
          } = OpenDatum
prevOpenDatum

    -- Decode D1's commits so we can build a snapshot whose
    -- utxoToCommit matches what the on-chain check expects.
    let network :: Network
network = NetworkId -> Network
toShelleyNetwork NetworkId
networkId
    [Commit]
d1Commits <- TxOut CtxUTxO -> IO [Commit]
readDepositCommits TxOut CtxUTxO
deposit1Out
    UTxO
utxoToCommit <-
      case (Commit -> Maybe (TxIn, TxOut CtxUTxO))
-> [Commit] -> Maybe [(TxIn, TxOut CtxUTxO)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO)
Commit.deserializeCommit Network
network) [Commit]
d1Commits of
        Just [(TxIn, TxOut CtxUTxO)]
outs -> UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> IO UTxO) -> UTxO -> IO UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList [(TxIn, TxOut CtxUTxO)]
outs
        Maybe [(TxIn, TxOut CtxUTxO)]
Nothing -> String -> IO UTxO
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"failed to deserialize D1 commits"

    -- Construct and sign the snapshot covering ONLY D1.
    let snapshot :: Snapshot (Tx Era)
snapshot =
          Snapshot
            { $sel:headId:Snapshot :: HeadId
Snapshot.headId = HeadId
headId
            , $sel:version:Snapshot :: SnapshotVersion
Snapshot.version = SnapshotVersion -> SnapshotVersion
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotVersion
prevVersion
            , $sel:number:Snapshot :: SnapshotNumber
Snapshot.number = SnapshotVersion -> SnapshotNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SnapshotVersion
prevVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1)
            , $sel:confirmed:Snapshot :: [Tx Era]
Snapshot.confirmed = []
            , $sel:utxo:Snapshot :: UTxOType (Tx Era)
Snapshot.utxo = UTxO
forall a. Monoid a => a
mempty :: CAPI.UTxO
            , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType (Tx Era))
Snapshot.utxoToCommit = UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToCommit
            , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType (Tx Era))
Snapshot.utxoToDecommit = Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing
            , $sel:depositTxId:Snapshot :: Maybe (TxIdType (Tx Era))
Snapshot.depositTxId = TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
deposit1TxId
            , $sel:accumulator:Snapshot :: HydraAccumulator
Snapshot.accumulator = forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs @CAPI.Tx UTxO
UTxOType (Tx Era)
forall a. Monoid a => a
mempty (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToCommit) Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing
            }
        sigs :: MultiSignature (Snapshot (Tx Era))
sigs = [Signature (Snapshot (Tx Era))]
-> MultiSignature (Snapshot (Tx Era))
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot (Tx Era) -> Signature (Snapshot (Tx Era))
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot (Tx Era)
snapshot]

    PParams ConwayEra
pparams <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (PParams ConwayEra))
 -> IO (PParams ConwayEra))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters QueryPoint
QueryTip
    SystemStart
systemStart <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m SystemStart)
 -> IO SystemStart)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
QueryTip
    EraHistory
eraHistory <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m EraHistory)
 -> IO EraHistory)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip
    Set PoolId
stakePools <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (Set PoolId))
 -> IO (Set PoolId))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (Set PoolId)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (Set PoolId)
queryStakePools QueryPoint
QueryTip
    ChainPoint
tip <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ChainPoint)
-> IO ChainPoint
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m ChainPoint
queryTip
    let tipSlot :: SlotNo
tipSlot = SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
tip)
        upperSlot :: SlotNo
upperSlot = SlotNo
tipSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
30

    let headRedeemer :: HashableScriptData
headRedeemer =
          Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
            IncrementRedeemer -> Input
Increment
              IncrementRedeemer
                { $sel:signature:IncrementRedeemer :: [Signature]
Head.signature = MultiSignature (Snapshot (Tx Era)) -> [Signature]
forall a. MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot (Tx Era))
sigs
                , $sel:snapshotNumber:IncrementRedeemer :: SnapshotVersion
Head.snapshotNumber = SnapshotVersion
prevVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1
                , $sel:increment:IncrementRedeemer :: TxOutRef
Head.increment = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
deposit1In
                , $sel:decommitOutputsHash:IncrementRedeemer :: Signature
Head.decommitOutputsHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @CAPI.Tx (UTxO
forall a. Monoid a => a
mempty :: CAPI.UTxO)
                }
        headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
          Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
            ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
headRedeemer

        claimRedeemer :: HashableScriptData
claimRedeemer = Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData) -> Redeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ DepositRedeemer -> Redeemer
Deposit.redeemer DepositRedeemer
Deposit.Claim
        depositWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness =
          Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
            ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
depositValidatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
claimRedeemer

        nextOpenDatum :: OpenDatum
nextOpenDatum =
          OpenDatum
            { $sel:headSeed:OpenDatum :: TxOutRef
Head.headSeed = TxOutRef
prevHeadSeed
            , $sel:headId:OpenDatum :: CurrencySymbol
Head.headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
            , $sel:parties:OpenDatum :: [Party]
Head.parties = [Party]
prevParties
            , $sel:contestationPeriod:OpenDatum :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
prevPeriod
            , $sel:depositPeriod:OpenDatum :: DepositPeriod
Head.depositPeriod = DepositPeriod
prevDepositPeriod
            , $sel:version:OpenDatum :: SnapshotVersion
Head.version = SnapshotVersion
prevVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1
            , $sel:accumulatorHash:OpenDatum :: Signature
Head.accumulatorHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ HydraAccumulator -> ByteString
Accumulator.getAccumulatorHash (HydraAccumulator -> ByteString) -> HydraAccumulator -> ByteString
forall a b. (a -> b) -> a -> b
$ forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs @CAPI.Tx UTxO
UTxOType (Tx Era)
forall a. Monoid a => a
mempty (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToCommit) Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing
            , $sel:headAdaOverhead:OpenDatum :: SnapshotVersion
Head.headAdaOverhead = SnapshotVersion
prevHeadAdaOverhead
            }
        headOut' :: TxOut CtxTx
headOut' =
          TxOut CtxUTxO -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
headOut
            TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (TxOutDatum CtxTx -> TxOutDatum CtxTx)
-> TxOut CtxTx -> TxOut CtxTx
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx
forall a b. a -> b -> a
const (TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx)
-> TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$ State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (OpenDatum -> State
Open OpenDatum
nextOpenDatum))
            TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (Value -> Value) -> TxOut CtxTx -> TxOut CtxTx
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
deposit1Out)

        redirectedOut :: TxOut CtxTx
redirectedOut =
          AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra Era
kateAddr (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
deposit2Out) TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone

        body :: TxBodyContent BuildTx Era
body =
          TxBodyContent BuildTx Era
defaultTxBodyContent
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns
              [ (TxIn
headIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness)
              , (TxIn
deposit1In, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)
              , (TxIn
deposit2In, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)
              , (TxIn
aliceFundsIn, Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)
              ]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [TxOut CtxTx
headOut', TxOut CtxTx
redirectedOut]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsCollateral [TxIn
aliceFundsIn]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[Hash PaymentKey]
-> TxBodyContent build era -> TxBodyContent build era
addTxExtraKeyWits [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
aliceCardanoVk]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& TxValidityUpperBound Era
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
TxValidityUpperBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityUpperBound (SlotNo -> TxValidityUpperBound Era
TxValidityUpperBound SlotNo
upperSlot)
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
BuildTxWith build (Maybe (LedgerProtocolParameters era))
-> TxBodyContent build era -> TxBodyContent build era
setTxProtocolParams (Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters Era)
 -> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era)))
-> Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a. a -> Maybe a
Just (LedgerProtocolParameters Era
 -> Maybe (LedgerProtocolParameters Era))
-> LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
PParams ConwayEra
pparams)

        spendable :: CAPI.UTxO
        spendable :: UTxO
spendable =
          TxIn -> TxOut CtxUTxO -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
headIn TxOut CtxUTxO
headOut
            UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
deposit1UTxO
            UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
deposit2UTxO
            UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
aliceFundsUTxO
        aliceFundsAddr :: AddressInEra Era
aliceFundsAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
aliceFundsVk

    -- Attempt the redirection. D2's own Claim requires the head's Increment
    -- redeemer to name it (DepositNotClaimedByHead, D09).
    case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra Era
-> TxBodyContent BuildTx Era
-> UTxO
-> Either (TxBodyErrorAutoBalance Era) (Tx Era)
buildTransactionWithBody PParams LedgerEra
PParams ConwayEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra Era
aliceFundsAddr TxBodyContent BuildTx Era
body UTxO
spendable of
      Left TxBodyErrorAutoBalance Era
e ->
        TxBodyErrorAutoBalance Era -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyErrorAutoBalance Era
e String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` Text -> String
forall a. ToString a => a -> String
toString (DepositError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode DepositError
DepositNotClaimedByHead)
      Right Tx Era
_ ->
        Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected script evaluation to reject the redirection tx, but the build succeeded"

    -- Both deposits remain locked at v_deposit; Kate's address has nothing.
    ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
deposit1TxId (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
deposit1Out)
    ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
deposit2TxId (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
deposit2Out)
    ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
victim1Vk SnapshotVersion
0
    ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
victim2Vk SnapshotVersion
0
    ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
kateVk SnapshotVersion
0

-- * Increment-redirection helpers

-- | Like 'placeVictimDeposit' but does not wait for the hydra-node to
-- emit @CommitRecorded@. The caller is expected to exit the
-- 'withHydraNode' bracket promptly so the node cannot submit its own
-- honest Increment for the deposit.
placeVictimDepositNoWait ::
  Tracer IO EndToEndLog ->
  ChainBackendOptions ->
  HydraClient ->
  Integer ->
  IO (CAPI.VerificationKey CAPI.PaymentKey, TxId)
placeVictimDepositNoWait :: Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDepositNoWait Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 SnapshotVersion
amount = do
  (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
  UTxO
utxo <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
vk (Lovelace -> Value
lovelaceToValue (SnapshotVersion -> Lovelace
forall a. Num a => SnapshotVersion -> a
fromInteger SnapshotVersion
amount)) ((FaucetLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO FaucetLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap FaucetLog -> EndToEndLog
FromFaucet Tracer IO EndToEndLog
tracer)
  Tx Era
depositTx <- HydraClient -> UTxO -> IO (Tx Era)
requestCommitTx HydraClient
n1 UTxO
utxo IO (Tx Era) -> (Tx Era -> Tx Era) -> IO (Tx Era)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx Era -> Tx Era
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
sk
  ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m ())
 -> IO ())
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ Tx Era -> m ()
forall (m :: * -> *). ChainBackend m => Tx Era -> m ()
submitTransaction Tx Era
depositTx
  (VerificationKey PaymentKey, TxId)
-> IO (VerificationKey PaymentKey, TxId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationKey PaymentKey
vk, Tx Era -> TxIdType (Tx Era)
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx Era
depositTx)

-- | Poll the chain for a UTxO at the given TxIn until it appears.
-- Times out after ~30 seconds.
waitForOnChainUTxO :: ChainBackendOptions -> CAPI.TxIn -> IO CAPI.UTxO
waitForOnChainUTxO :: ChainBackendOptions -> TxIn -> IO UTxO
waitForOnChainUTxO ChainBackendOptions
opts TxIn
txIn = Int -> IO UTxO
go (Int
60 :: Int)
 where
  go :: Int -> IO UTxO
go Int
0 = String -> IO UTxO
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO UTxO) -> String -> IO UTxO
forall a b. (a -> b) -> a -> b
$ String
"UTxO " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxIn -> String
forall b a. (Show a, IsString b) => a -> b
show TxIn
txIn String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" never appeared on chain"
  go Int
n = do
    UTxO
utxo <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m UTxO)
 -> IO UTxO)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a b. (a -> b) -> a -> b
$ [TxIn] -> m UTxO
forall (m :: * -> *). ChainBackend m => [TxIn] -> m UTxO
queryUTxOByTxIn [TxIn
txIn]
    if UTxO -> Bool
forall era. UTxO era -> Bool
UTxO.null UTxO
utxo
      then DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5 IO () -> IO UTxO -> IO UTxO
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO UTxO
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      else UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO
utxo

-- | Locate the head's continuation UTxO at v_head address, identified
-- by its state token policy id matching the head id.
findHeadContinuationUTxO ::
  ChainBackendOptions ->
  CAPI.NetworkId ->
  HeadId ->
  IO (CAPI.TxIn, CAPI.TxOut CAPI.CtxUTxO, OpenDatum)
findHeadContinuationUTxO :: ChainBackendOptions
-> NetworkId -> HeadId -> IO (TxIn, TxOut CtxUTxO, OpenDatum)
findHeadContinuationUTxO ChainBackendOptions
opts NetworkId
networkId HeadId
headId = do
  let headAddr :: Address ShelleyAddr
headAddr =
        case NetworkId -> PlutusScript -> AddressInEra Era
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript
Head.validatorScript of
          ShelleyAddressInEra Address ShelleyAddr
addr -> Address ShelleyAddr
addr
          AddressInEra Era
_ -> Text -> Address ShelleyAddr
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"head address is not Shelley"
  PolicyId
headPolicyId <- IO PolicyId
-> (PolicyId -> IO PolicyId) -> Maybe PolicyId -> IO PolicyId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO PolicyId
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"head id is not a valid policy id") PolicyId -> IO PolicyId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId)
  UTxO
allHeadUTxOs <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m UTxO)
 -> IO UTxO)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m UTxO)
-> IO UTxO
forall a b. (a -> b) -> a -> b
$ [Address ShelleyAddr] -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
[Address ShelleyAddr] -> m UTxO
queryUTxO [Address ShelleyAddr
headAddr]
  let matches :: UTxO
matches =
        (TxOut CtxUTxO -> Bool) -> UTxO -> UTxO
forall era. (TxOut CtxUTxO era -> Bool) -> UTxO era -> UTxO era
UTxO.filter
          ( \TxOut CtxUTxO
o ->
              Value -> AssetId -> Quantity
CAPI.selectAsset (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
o) (PolicyId -> AssetName -> AssetId
AssetId PolicyId
headPolicyId AssetName
hydraHeadV2AssetName)
                Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion -> Quantity
Quantity SnapshotVersion
1
          )
          UTxO
allHeadUTxOs
  (TxIn
headIn, TxOut CtxUTxO
headOut) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"head continuation UTxO" UTxO
matches
  case TxOut CtxTx -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
headOut) of
    Maybe HashableScriptData
Nothing -> String -> IO (TxIn, TxOut CtxUTxO, OpenDatum)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"head UTxO has no inline datum"
    Just HashableScriptData
sd -> case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
sd of
      Just (Open OpenDatum
openDatum) -> (TxIn, TxOut CtxUTxO, OpenDatum)
-> IO (TxIn, TxOut CtxUTxO, OpenDatum)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn
headIn, TxOut CtxUTxO
headOut, OpenDatum
openDatum)
      Maybe State
_ -> String -> IO (TxIn, TxOut CtxUTxO, OpenDatum)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"head UTxO datum is not Open"

-- | Read the @[Commit]@ list from a deposit-script UTxO's inline datum.
readDepositCommits :: CAPI.TxOut CAPI.CtxUTxO -> IO [Commit.Commit]
readDepositCommits :: TxOut CtxUTxO -> IO [Commit]
readDepositCommits TxOut CtxUTxO
depositOut =
  case TxOut CtxTx -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxUTxO -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
depositOut) of
    Maybe HashableScriptData
Nothing -> String -> IO [Commit]
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"deposit UTxO has no inline datum"
    Just HashableScriptData
sd -> case HashableScriptData -> Maybe DepositDatum
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
sd :: Maybe Deposit.DepositDatum of
      Just (CurrencySymbol
_, POSIXTime
_, [Commit]
commits) -> [Commit] -> IO [Commit]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Commit]
commits
      Maybe DepositDatum
Nothing -> String -> IO [Commit]
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"deposit UTxO datum doesn't decode"

-- * Close-with-deposit absorption

-- | A malicious head participant closes the head with a transaction
-- that ALSO spends a foreign deposit input, padding the closed-state
-- continuation's value with the deposit's value (mustPreserveHeadValue
-- uses 'geq', so head_out > head_in is allowed). After the contestation
-- deadline they fanout the absorbed value to their own address. The
-- deposit validator's @head_output_is_open@ check requires the head's
-- continuation datum to be the Open state, so Close / Contest / Fanout
-- transitions cannot absorb deposits and the tx is rejected with
-- @HeadOutputNotOpen@ (D06).
--
-- The test uses the simplest of the close redeemers, 'CloseInitial',
-- which doesn't require an off-chain snapshot signature: just
-- snapshotNumber = 0 and utxoHash = the open's initialUtxoHash.
cannotAbsorbDepositDuringClose ::
  Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
cannotAbsorbDepositDuringClose :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
cannotAbsorbDepositDuringClose Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId =
  (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
60_000_000
    NominalDiffTime
blockTime <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NominalDiffTime)
-> IO NominalDiffTime
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NominalDiffTime
getBlockTime
    let timing :: Timing
timing = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
    NetworkId
networkId <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NetworkId)
-> IO NetworkId
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NetworkId
queryNetworkId
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [] Timing
timing
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId
    let hydraTracer :: Tracer IO HydraNodeLog
hydraTracer = (HydraNodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO HydraNodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog -> EndToEndLog
FromHydraNode Tracer IO EndToEndLog
tracer

    -- Bootstrap the head and craft the deposit tx; exit before the node
    -- can auto-Increment.
    (HeadId
headId, VerificationKey PaymentKey
victimVk, TxId
depositTxId') <-
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO (HeadId, VerificationKey PaymentKey, TxId))
-> IO (HeadId, VerificationKey PaymentKey, TxId)
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO (HeadId, VerificationKey PaymentKey, TxId))
 -> IO (HeadId, VerificationKey PaymentKey, TxId))
-> (HydraClient -> IO (HeadId, VerificationKey PaymentKey, TxId))
-> IO (HeadId, VerificationKey PaymentKey, TxId)
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
        HeadId
hid <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsOpenWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])
        (VerificationKey PaymentKey
vVk, TxId
dTxId) <- Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDepositNoWait Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 SnapshotVersion
5_000_000
        (HeadId, VerificationKey PaymentKey, TxId)
-> IO (HeadId, VerificationKey PaymentKey, TxId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
hid, VerificationKey PaymentKey
vVk, TxId
dTxId)

    UTxO
depositUTxO <- ChainBackendOptions -> TxIn -> IO UTxO
waitForOnChainUTxO ChainBackendOptions
opts (TxId -> TxIx -> TxIn
CAPI.TxIn TxId
depositTxId' (Word -> TxIx
CAPI.TxIx Word
0))
    (TxIn
depositTxIn, TxOut CtxUTxO
depositTxOut) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"deposit UTxO" UTxO
depositUTxO

    (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_aliceCardanoSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice
    (VerificationKey PaymentKey
aliceFundsVk, Secret (SigningKey PaymentKey)
_aliceFundsSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
AliceFunds
    UTxO
aliceFundsUTxO <-
      ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet
        ChainBackendOptions
opts
        VerificationKey PaymentKey
aliceFundsVk
        (Lovelace -> Value
lovelaceToValue Lovelace
30_000_000)
        ((FaucetLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO FaucetLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap FaucetLog -> EndToEndLog
FromFaucet Tracer IO EndToEndLog
tracer)
    (TxIn
aliceFundsIn, TxOut CtxUTxO
_) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"Alice funds" UTxO
aliceFundsUTxO

    (TxIn
headIn, TxOut CtxUTxO
headOut, OpenDatum
prevOpenDatum) <-
      ChainBackendOptions
-> NetworkId -> HeadId -> IO (TxIn, TxOut CtxUTxO, OpenDatum)
findHeadContinuationUTxO ChainBackendOptions
opts NetworkId
networkId HeadId
headId
    let OpenDatum
          { $sel:headSeed:OpenDatum :: OpenDatum -> TxOutRef
Head.headSeed = TxOutRef
_prevHeadSeed
          , $sel:parties:OpenDatum :: OpenDatum -> [Party]
Head.parties = [Party]
prevParties
          , $sel:contestationPeriod:OpenDatum :: OpenDatum -> ContestationPeriod
Head.contestationPeriod = ContestationPeriod
prevPeriod
          , $sel:depositPeriod:OpenDatum :: OpenDatum -> DepositPeriod
Head.depositPeriod = DepositPeriod
prevDepositPeriod
          , $sel:version:OpenDatum :: OpenDatum -> SnapshotVersion
Head.version = SnapshotVersion
prevVersion
          } = OpenDatum
prevOpenDatum

    PParams ConwayEra
pparams <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (PParams ConwayEra))
 -> IO (PParams ConwayEra))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters QueryPoint
QueryTip
    SystemStart
systemStart <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m SystemStart)
 -> IO SystemStart)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
QueryTip
    EraHistory
eraHistory <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m EraHistory)
 -> IO EraHistory)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip
    Set PoolId
stakePools <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (Set PoolId))
 -> IO (Set PoolId))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (Set PoolId)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (Set PoolId)
queryStakePools QueryPoint
QueryTip
    ChainPoint
tip <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ChainPoint)
-> IO ChainPoint
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m ChainPoint
queryTip
    let tipSlot :: SlotNo
tipSlot = SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
tip)
        -- Keep the validity range tight (<= contestationPeriod). With test
        -- timing of contestationPeriod = 2s and slot length 1s,
        -- 1-slot range is well within bounds.
        lowerSlot :: SlotNo
lowerSlot = SlotNo
tipSlot
        upperSlot :: SlotNo
upperSlot = SlotNo
tipSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1
        timeHandle :: TimeHandle
timeHandle = SlotNo -> SystemStart -> EraHistory -> TimeHandle
mkTimeHandle SlotNo
tipSlot SystemStart
systemStart EraHistory
eraHistory
    UTCTime
upperUTC <- (Text -> IO UTCTime)
-> (UTCTime -> IO UTCTime) -> Either Text UTCTime -> IO UTCTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO UTCTime
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO UTCTime) -> (Text -> String) -> Text -> IO UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) UTCTime -> IO UTCTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime TimeHandle
timeHandle SlotNo
upperSlot)
    let upperPosix :: POSIXTime
upperPosix = UTCTime -> POSIXTime
posixFromUTCTime UTCTime
upperUTC
        contestationDeadline :: POSIXTime
contestationDeadline = POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod POSIXTime
upperPosix ContestationPeriod
prevPeriod

    let closedDatum :: ClosedDatum
closedDatum =
          ClosedDatum
            { $sel:headId:ClosedDatum :: CurrencySymbol
Head.headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
            , $sel:parties:ClosedDatum :: [Party]
Head.parties = [Party]
prevParties
            , $sel:contestationPeriod:ClosedDatum :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
prevPeriod
            , $sel:depositPeriod:ClosedDatum :: DepositPeriod
Head.depositPeriod = DepositPeriod
prevDepositPeriod
            , $sel:version:ClosedDatum :: SnapshotVersion
Head.version = SnapshotVersion
prevVersion
            , $sel:snapshotNumber:ClosedDatum :: SnapshotVersion
Head.snapshotNumber = SnapshotVersion
0
            , $sel:contesters:ClosedDatum :: [PubKeyHash]
Head.contesters = []
            , $sel:contestationDeadline:ClosedDatum :: POSIXTime
Head.contestationDeadline = POSIXTime
contestationDeadline
            , $sel:accumulatorCommitment:ClosedDatum :: BuiltinBLS12_381_G1_Element
Head.accumulatorCommitment = HydraAccumulator -> BuiltinBLS12_381_G1_Element
Accumulator.getAccumulatorCommitment (HydraAccumulator -> BuiltinBLS12_381_G1_Element)
-> HydraAccumulator -> BuiltinBLS12_381_G1_Element
forall a b. (a -> b) -> a -> b
$ forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs @CAPI.Tx UTxO
UTxOType (Tx Era)
forall a. Monoid a => a
mempty Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing
            , $sel:headAdaOverhead:ClosedDatum :: SnapshotVersion
Head.headAdaOverhead = SnapshotVersion
0
            }

        headRedeemer :: HashableScriptData
headRedeemer = Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (CloseRedeemer -> Input
Close CloseRedeemer
CloseInitial)
        headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
          Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
            ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
headRedeemer

        claimRedeemer :: HashableScriptData
claimRedeemer = Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData) -> Redeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ DepositRedeemer -> Redeemer
Deposit.redeemer DepositRedeemer
Deposit.Claim
        depositWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness =
          Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
            ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
depositValidatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
claimRedeemer

        headOut' :: TxOut CtxTx
headOut' =
          TxOut CtxUTxO -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
headOut
            TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (TxOutDatum CtxTx -> TxOutDatum CtxTx)
-> TxOut CtxTx -> TxOut CtxTx
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx
forall a b. a -> b -> a
const (TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx)
-> TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$ State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (ClosedDatum -> State
Closed ClosedDatum
closedDatum))
            TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (Value -> Value) -> TxOut CtxTx -> TxOut CtxTx
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
depositTxOut)

        body :: TxBodyContent BuildTx Era
body =
          TxBodyContent BuildTx Era
defaultTxBodyContent
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns
              [ (TxIn
headIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness)
              , (TxIn
depositTxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)
              , (TxIn
aliceFundsIn, Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)
              ]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [TxOut CtxTx
headOut']
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsCollateral [TxIn
aliceFundsIn]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[Hash PaymentKey]
-> TxBodyContent build era -> TxBodyContent build era
addTxExtraKeyWits [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
aliceCardanoVk]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& TxValidityLowerBound Era
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
TxValidityLowerBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityLowerBound (SlotNo -> TxValidityLowerBound Era
TxValidityLowerBound SlotNo
lowerSlot)
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& TxValidityUpperBound Era
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
TxValidityUpperBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityUpperBound (SlotNo -> TxValidityUpperBound Era
TxValidityUpperBound SlotNo
upperSlot)
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
BuildTxWith build (Maybe (LedgerProtocolParameters era))
-> TxBodyContent build era -> TxBodyContent build era
setTxProtocolParams (Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters Era)
 -> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era)))
-> Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a. a -> Maybe a
Just (LedgerProtocolParameters Era
 -> Maybe (LedgerProtocolParameters Era))
-> LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
PParams ConwayEra
pparams)

        spendable :: CAPI.UTxO
        spendable :: UTxO
spendable =
          TxIn -> TxOut CtxUTxO -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
headIn TxOut CtxUTxO
headOut UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
depositUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
aliceFundsUTxO
        aliceFundsAddr :: AddressInEra Era
aliceFundsAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
aliceFundsVk

    case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra Era
-> TxBodyContent BuildTx Era
-> UTxO
-> Either (TxBodyErrorAutoBalance Era) (Tx Era)
buildTransactionWithBody PParams LedgerEra
PParams ConwayEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra Era
aliceFundsAddr TxBodyContent BuildTx Era
body UTxO
spendable of
      Left TxBodyErrorAutoBalance Era
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Right Tx Era
_ ->
        Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected script evaluation to reject the close-with-deposit tx, but the build succeeded"

    -- The deposit is still locked at v_deposit; nothing was redirected.
    ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
depositTxId' (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
depositTxOut)
    ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
victimVk SnapshotVersion
0

-- * Leader self-deposit cover redirection

-- | The malicious snapshot leader places their own SMALL deposit alongside
-- a much LARGER unrelated victim deposit, then constructs an Increment that
-- claims their own small deposit (which is in the snapshot they sign) but
-- ALSO consumes the victim's larger deposit and routes its value to a
-- leader-controlled wallet ("their own pocket") rather than to the head.
--
-- Compared to 'cannotRedirectExtraDepositDuringIncrement' (two unrelated
-- depositors, redirection to a third party), this captures the threat
-- model where the leader benefits *directly* and uses their own honest
-- deposit as cover ("I was just incrementing my deposit"). The asymmetric
-- amounts (small honest, large stolen) make the economic motive explicit.
--
-- The on-chain defense is the same as there: the victim's deposit rejects its
-- own Claim because the head's Increment redeemer does not name it
-- (@DepositNotClaimedByHead@, D09).
--
-- TODO: This could move into the MutationSpec or the TraceSpec.
cannotStealLargerDepositDuringOwnIncrement ::
  Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
cannotStealLargerDepositDuringOwnIncrement :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
cannotStealLargerDepositDuringOwnIncrement Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId =
  (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
60_000_000
    NominalDiffTime
blockTime <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NominalDiffTime)
-> IO NominalDiffTime
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NominalDiffTime
forall (m :: * -> *). ChainBackend m => m NominalDiffTime
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NominalDiffTime
getBlockTime
    let timing :: Timing
timing = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
    NetworkId
networkId <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m NetworkId)
-> IO NetworkId
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m NetworkId
forall (m :: * -> *). ChainBackend m => m NetworkId
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m NetworkId
queryNetworkId
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [] Timing
timing
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId
    let hydraTracer :: Tracer IO HydraNodeLog
hydraTracer = (HydraNodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO HydraNodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog -> EndToEndLog
FromHydraNode Tracer IO EndToEndLog
tracer

    -- Bootstrap the head and produce both deposits, exiting before the
    -- node can submit its own honest Increment.
    --
    -- The "leader" deposit is small (3 ADA) and sits in the leader's own
    -- depositor wallet — it is the cover the leader will sign a snapshot
    -- over. The "victim" deposit is much larger (20 ADA) and is what the
    -- leader will redirect.
    (HeadId
headId, VerificationKey PaymentKey
leaderDepositorVk, TxId
leaderDepositTxId, VerificationKey PaymentKey
victimVk, TxId
victimDepositTxId) <-
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient
    -> IO
         (HeadId, VerificationKey PaymentKey, TxId,
          VerificationKey PaymentKey, TxId))
-> IO
     (HeadId, VerificationKey PaymentKey, TxId,
      VerificationKey PaymentKey, TxId)
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient
  -> IO
       (HeadId, VerificationKey PaymentKey, TxId,
        VerificationKey PaymentKey, TxId))
 -> IO
      (HeadId, VerificationKey PaymentKey, TxId,
       VerificationKey PaymentKey, TxId))
-> (HydraClient
    -> IO
         (HeadId, VerificationKey PaymentKey, TxId,
          VerificationKey PaymentKey, TxId))
-> IO
     (HeadId, VerificationKey PaymentKey, TxId,
      VerificationKey PaymentKey, TxId)
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
        HeadId
hid <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsOpenWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])
        (VerificationKey PaymentKey
lVk, TxId
lTxId) <- Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDepositNoWait Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 SnapshotVersion
3_000_000
        (VerificationKey PaymentKey
vVk, TxId
vTxId) <- Tracer IO EndToEndLog
-> ChainBackendOptions
-> HydraClient
-> SnapshotVersion
-> IO (VerificationKey PaymentKey, TxId)
placeVictimDepositNoWait Tracer IO EndToEndLog
tracer ChainBackendOptions
opts HydraClient
n1 SnapshotVersion
20_000_000
        (HeadId, VerificationKey PaymentKey, TxId,
 VerificationKey PaymentKey, TxId)
-> IO
     (HeadId, VerificationKey PaymentKey, TxId,
      VerificationKey PaymentKey, TxId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
hid, VerificationKey PaymentKey
lVk, TxId
lTxId, VerificationKey PaymentKey
vVk, TxId
vTxId)

    UTxO
leaderDepositUTxO <- ChainBackendOptions -> TxIn -> IO UTxO
waitForOnChainUTxO ChainBackendOptions
opts (TxId -> TxIx -> TxIn
CAPI.TxIn TxId
leaderDepositTxId (Word -> TxIx
CAPI.TxIx Word
0))
    UTxO
victimDepositUTxO <- ChainBackendOptions -> TxIn -> IO UTxO
waitForOnChainUTxO ChainBackendOptions
opts (TxId -> TxIx -> TxIn
CAPI.TxIn TxId
victimDepositTxId (Word -> TxIx
CAPI.TxIx Word
0))
    (TxIn
leaderDepositIn, TxOut CtxUTxO
leaderDepositOut) <-
      HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"leader deposit UTxO" UTxO
leaderDepositUTxO
    (TxIn
victimDepositIn, TxOut CtxUTxO
victimDepositOut) <-
      HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"victim deposit UTxO" UTxO
victimDepositUTxO

    (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_aliceCardanoSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice
    (VerificationKey PaymentKey
aliceFundsVk, Secret (SigningKey PaymentKey)
_aliceFundsSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
AliceFunds
    UTxO
aliceFundsUTxO <-
      ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet
        ChainBackendOptions
opts
        VerificationKey PaymentKey
aliceFundsVk
        (Lovelace -> Value
lovelaceToValue Lovelace
30_000_000)
        ((FaucetLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO FaucetLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap FaucetLog -> EndToEndLog
FromFaucet Tracer IO EndToEndLog
tracer)
    (TxIn
aliceFundsIn, TxOut CtxUTxO
_) <- HasCallStack => String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
String -> UTxO -> IO (TxIn, TxOut CtxUTxO)
requireSingletonUTxO String
"Alice funds" UTxO
aliceFundsUTxO

    -- Fresh wallet representing "the leader's pocket" — using a wallet
    -- with zero starting balance keeps the post-attack assertion crisp.
    (VerificationKey PaymentKey
lootVk, SigningKey PaymentKey
_) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
    let lootAddr :: AddressInEra Era
lootAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
lootVk

    (TxIn
headIn, TxOut CtxUTxO
headOut, OpenDatum
prevOpenDatum) <-
      ChainBackendOptions
-> NetworkId -> HeadId -> IO (TxIn, TxOut CtxUTxO, OpenDatum)
findHeadContinuationUTxO ChainBackendOptions
opts NetworkId
networkId HeadId
headId
    let OpenDatum
          { $sel:headSeed:OpenDatum :: OpenDatum -> TxOutRef
Head.headSeed = TxOutRef
prevHeadSeed
          , $sel:parties:OpenDatum :: OpenDatum -> [Party]
Head.parties = [Party]
prevParties
          , $sel:contestationPeriod:OpenDatum :: OpenDatum -> ContestationPeriod
Head.contestationPeriod = ContestationPeriod
prevPeriod
          , $sel:depositPeriod:OpenDatum :: OpenDatum -> DepositPeriod
Head.depositPeriod = DepositPeriod
prevDepositPeriod
          , $sel:version:OpenDatum :: OpenDatum -> SnapshotVersion
Head.version = SnapshotVersion
prevVersion
          , $sel:headAdaOverhead:OpenDatum :: OpenDatum -> SnapshotVersion
Head.headAdaOverhead = SnapshotVersion
prevHeadAdaOverhead
          } = OpenDatum
prevOpenDatum

    -- Snapshot covers ONLY the leader's own (small) deposit. This is
    -- what the leader signs; the victim's deposit is silently consumed
    -- by the on-chain tx and never appears in any signed snapshot.
    let network :: Network
network = NetworkId -> Network
toShelleyNetwork NetworkId
networkId
    [Commit]
leaderCommits <- TxOut CtxUTxO -> IO [Commit]
readDepositCommits TxOut CtxUTxO
leaderDepositOut
    UTxO
utxoToCommit <-
      case (Commit -> Maybe (TxIn, TxOut CtxUTxO))
-> [Commit] -> Maybe [(TxIn, TxOut CtxUTxO)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO)
Commit.deserializeCommit Network
network) [Commit]
leaderCommits of
        Just [(TxIn, TxOut CtxUTxO)]
outs -> UTxO -> IO UTxO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> IO UTxO) -> UTxO -> IO UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList [(TxIn, TxOut CtxUTxO)]
outs
        Maybe [(TxIn, TxOut CtxUTxO)]
Nothing -> String -> IO UTxO
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"failed to deserialize leader-deposit commits"

    let snapshot :: Snapshot (Tx Era)
snapshot =
          Snapshot
            { $sel:headId:Snapshot :: HeadId
Snapshot.headId = HeadId
headId
            , $sel:version:Snapshot :: SnapshotVersion
Snapshot.version = SnapshotVersion -> SnapshotVersion
forall a b. (Integral a, Num b) => a -> b
fromIntegral SnapshotVersion
prevVersion
            , $sel:number:Snapshot :: SnapshotNumber
Snapshot.number = SnapshotVersion -> SnapshotNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SnapshotVersion
prevVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1)
            , $sel:confirmed:Snapshot :: [Tx Era]
Snapshot.confirmed = []
            , $sel:utxo:Snapshot :: UTxOType (Tx Era)
Snapshot.utxo = UTxO
forall a. Monoid a => a
mempty :: CAPI.UTxO
            , $sel:utxoToCommit:Snapshot :: Maybe (UTxOType (Tx Era))
Snapshot.utxoToCommit = UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToCommit
            , $sel:utxoToDecommit:Snapshot :: Maybe (UTxOType (Tx Era))
Snapshot.utxoToDecommit = Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing
            , $sel:depositTxId:Snapshot :: Maybe (TxIdType (Tx Era))
Snapshot.depositTxId = TxId -> Maybe TxId
forall a. a -> Maybe a
Just TxId
leaderDepositTxId
            , $sel:accumulator:Snapshot :: HydraAccumulator
Snapshot.accumulator = forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs @CAPI.Tx UTxO
UTxOType (Tx Era)
forall a. Monoid a => a
mempty (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToCommit) Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing
            }
        sigs :: MultiSignature (Snapshot (Tx Era))
sigs = [Signature (Snapshot (Tx Era))]
-> MultiSignature (Snapshot (Tx Era))
forall a. [Signature a] -> MultiSignature a
aggregate [Secret (SigningKey HydraKey)
-> Snapshot (Tx Era) -> Signature (Snapshot (Tx Era))
forall a.
SignableRepresentation a =>
Secret (SigningKey HydraKey) -> a -> Signature a
sign Secret (SigningKey HydraKey)
aliceSk Snapshot (Tx Era)
snapshot]

    PParams ConwayEra
pparams <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (PParams ConwayEra))
 -> IO (PParams ConwayEra))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (PParams ConwayEra))
-> IO (PParams ConwayEra)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (PParams LedgerEra)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (PParams LedgerEra)
queryProtocolParameters QueryPoint
QueryTip
    SystemStart
systemStart <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m SystemStart)
 -> IO SystemStart)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m SystemStart)
-> IO SystemStart
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m SystemStart
forall (m :: * -> *). ChainBackend m => QueryPoint -> m SystemStart
querySystemStart QueryPoint
QueryTip
    EraHistory
eraHistory <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m EraHistory)
 -> IO EraHistory)
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m EraHistory)
-> IO EraHistory
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m EraHistory
forall (m :: * -> *). ChainBackend m => QueryPoint -> m EraHistory
queryEraHistory QueryPoint
QueryTip
    Set PoolId
stakePools <- ChainBackendOptions
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts ((forall {m :: * -> *}.
  (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
  m (Set PoolId))
 -> IO (Set PoolId))
-> (forall {m :: * -> *}.
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Set PoolId))
-> IO (Set PoolId)
forall a b. (a -> b) -> a -> b
$ QueryPoint -> m (Set PoolId)
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> m (Set PoolId)
queryStakePools QueryPoint
QueryTip
    ChainPoint
tip <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m ChainPoint)
-> IO ChainPoint
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts m ChainPoint
forall (m :: * -> *). ChainBackend m => m ChainPoint
forall (m :: * -> *).
(ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
m ChainPoint
queryTip
    let tipSlot :: SlotNo
tipSlot = SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
tip)
        upperSlot :: SlotNo
upperSlot = SlotNo
tipSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
30

    let headRedeemer :: HashableScriptData
headRedeemer =
          Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Input -> HashableScriptData) -> Input -> HashableScriptData
forall a b. (a -> b) -> a -> b
$
            IncrementRedeemer -> Input
Increment
              IncrementRedeemer
                { $sel:signature:IncrementRedeemer :: [Signature]
Head.signature = MultiSignature (Snapshot (Tx Era)) -> [Signature]
forall a. MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot (Tx Era))
sigs
                , $sel:snapshotNumber:IncrementRedeemer :: SnapshotVersion
Head.snapshotNumber = SnapshotVersion
prevVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1
                , $sel:increment:IncrementRedeemer :: TxOutRef
Head.increment = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
leaderDepositIn
                , $sel:decommitOutputsHash:IncrementRedeemer :: Signature
Head.decommitOutputsHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @CAPI.Tx (UTxO
forall a. Monoid a => a
mempty :: CAPI.UTxO)
                }
        headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
          Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
            ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
headRedeemer

        claimRedeemer :: HashableScriptData
claimRedeemer = Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData) -> Redeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ DepositRedeemer -> Redeemer
Deposit.redeemer DepositRedeemer
Deposit.Claim
        depositWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness =
          Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
            ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
              PlutusScript
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> HashableScriptData -> ScriptWitness ctx era
mkScriptWitness PlutusScript
depositValidatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
claimRedeemer

        nextOpenDatum :: OpenDatum
nextOpenDatum =
          OpenDatum
            { $sel:headSeed:OpenDatum :: TxOutRef
Head.headSeed = TxOutRef
prevHeadSeed
            , $sel:headId:OpenDatum :: CurrencySymbol
Head.headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
            , $sel:parties:OpenDatum :: [Party]
Head.parties = [Party]
prevParties
            , $sel:contestationPeriod:OpenDatum :: ContestationPeriod
Head.contestationPeriod = ContestationPeriod
prevPeriod
            , $sel:depositPeriod:OpenDatum :: DepositPeriod
Head.depositPeriod = DepositPeriod
prevDepositPeriod
            , $sel:version:OpenDatum :: SnapshotVersion
Head.version = SnapshotVersion
prevVersion SnapshotVersion -> SnapshotVersion -> SnapshotVersion
forall a. Num a => a -> a -> a
+ SnapshotVersion
1
            , $sel:accumulatorHash:OpenDatum :: Signature
Head.accumulatorHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ HydraAccumulator -> ByteString
Accumulator.getAccumulatorHash (HydraAccumulator -> ByteString) -> HydraAccumulator -> ByteString
forall a b. (a -> b) -> a -> b
$ forall tx.
IsTx tx =>
UTxOType tx
-> Maybe (UTxOType tx) -> Maybe (UTxOType tx) -> HydraAccumulator
Accumulator.buildFromSnapshotUTxOs @CAPI.Tx UTxO
UTxOType (Tx Era)
forall a. Monoid a => a
mempty (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
utxoToCommit) Maybe UTxO
Maybe (UTxOType (Tx Era))
forall a. Maybe a
Nothing
            , $sel:headAdaOverhead:OpenDatum :: SnapshotVersion
Head.headAdaOverhead = SnapshotVersion
prevHeadAdaOverhead
            }
        -- Head value grows by ONLY the leader's small deposit; the
        -- victim's value is siphoned to lootAddr.
        headOut' :: TxOut CtxTx
headOut' =
          TxOut CtxUTxO -> TxOut CtxTx
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
headOut
            TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (TxOutDatum CtxTx -> TxOutDatum CtxTx)
-> TxOut CtxTx -> TxOut CtxTx
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx
forall a b. a -> b -> a
const (TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx)
-> TxOutDatum CtxTx -> TxOutDatum CtxTx -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$ State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (OpenDatum -> State
Open OpenDatum
nextOpenDatum))
            TxOut CtxTx -> (TxOut CtxTx -> TxOut CtxTx) -> TxOut CtxTx
forall a b. a -> (a -> b) -> b
& (Value -> Value) -> TxOut CtxTx -> TxOut CtxTx
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
leaderDepositOut)

        redirectedOut :: TxOut CtxTx
redirectedOut =
          AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra Era
lootAddr (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
victimDepositOut) TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript
ReferenceScriptNone

        body :: TxBodyContent BuildTx Era
body =
          TxBodyContent BuildTx Era
defaultTxBodyContent
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns
              [ (TxIn
headIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness)
              , (TxIn
leaderDepositIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)
              , (TxIn
victimDepositIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
depositWitness)
              , (TxIn
aliceFundsIn, Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn
forall ctx. KeyWitnessInCtx ctx -> Witness ctx
KeyWitness KeyWitnessInCtx WitCtxTxIn
KeyWitnessForSpending)
              ]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [TxOut CtxTx
headOut', TxOut CtxTx
redirectedOut]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsCollateral [TxIn
aliceFundsIn]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[Hash PaymentKey]
-> TxBodyContent build era -> TxBodyContent build era
addTxExtraKeyWits [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
aliceCardanoVk]
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& TxValidityUpperBound Era
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
TxValidityUpperBound era
-> TxBodyContent build era -> TxBodyContent build era
setTxValidityUpperBound (SlotNo -> TxValidityUpperBound Era
TxValidityUpperBound SlotNo
upperSlot)
            TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
BuildTxWith build (Maybe (LedgerProtocolParameters era))
-> TxBodyContent build era -> TxBodyContent build era
setTxProtocolParams (Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters Era)
 -> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era)))
-> Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a. a -> Maybe a
Just (LedgerProtocolParameters Era
 -> Maybe (LedgerProtocolParameters Era))
-> LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
PParams ConwayEra
pparams)

        spendable :: CAPI.UTxO
        spendable :: UTxO
spendable =
          TxIn -> TxOut CtxUTxO -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
headIn TxOut CtxUTxO
headOut
            UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
leaderDepositUTxO
            UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
victimDepositUTxO
            UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
aliceFundsUTxO
        aliceFundsAddr :: AddressInEra Era
aliceFundsAddr = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
aliceFundsVk

    case PParams LedgerEra
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra Era
-> TxBodyContent BuildTx Era
-> UTxO
-> Either (TxBodyErrorAutoBalance Era) (Tx Era)
buildTransactionWithBody PParams LedgerEra
PParams ConwayEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools AddressInEra Era
aliceFundsAddr TxBodyContent BuildTx Era
body UTxO
spendable of
      Left TxBodyErrorAutoBalance Era
e ->
        TxBodyErrorAutoBalance Era -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyErrorAutoBalance Era
e String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` Text -> String
forall a. ToString a => a -> String
toString (DepositError -> Text
forall a. ToErrorCode a => a -> Text
toErrorCode DepositError
DepositNotClaimedByHead)
      Right Tx Era
_ ->
        Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"expected script evaluation to reject the leader-redirect tx, but the build succeeded"

    -- Both deposits remain locked at v_deposit; the loot wallet has nothing.
    ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
leaderDepositTxId (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
leaderDepositOut)
    ChainBackendOptions -> TxId -> Value -> IO ()
assertDepositStillLocked ChainBackendOptions
opts TxId
victimDepositTxId (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
victimDepositOut)
    ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
leaderDepositorVk SnapshotVersion
0
    ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
victimVk SnapshotVersion
0
    ChainBackendOptions
-> VerificationKey PaymentKey -> SnapshotVersion -> IO ()
assertWalletLovelace ChainBackendOptions
opts VerificationKey PaymentKey
lootVk SnapshotVersion
0