{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

module Hydra.Cluster.Scenarios (
  module Hydra.Cluster.Scenarios,
  EndToEndLog (..),
) where

import Hydra.Prelude
import Test.Hydra.Prelude hiding (HydraTestnet (..))

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Address (AccountId (..), pattern AccountAddress)
import Cardano.Ledger.Alonzo.Tx (ScriptIntegrity (..), hashScriptIntegrity)
import Cardano.Ledger.Alonzo.TxWits (unRedeemersL, unTxDatsL)
import Cardano.Ledger.Api (Withdrawals (..), collateralInputsTxBodyL, hashScript, scriptTxWitsL, totalCollateralTxBodyL, withdrawalsTxBodyL)
import Cardano.Ledger.Api.PParams (AlonzoEraPParams, PParams, getLanguageView)
import Cardano.Ledger.Api.Tx (AsIx (..), EraTx, Redeemers (..), bodyTxL, datsTxWitsL, rdmrsTxWitsL, witsTxL)
import Cardano.Ledger.Api.Tx qualified as Ledger
import Cardano.Ledger.Api.Tx.Body (AlonzoEraTxBody, scriptIntegrityHashTxBodyL)
import Cardano.Ledger.Api.Tx.Wits (AlonzoEraTxWits, ConwayPlutusPurpose (ConwayRewarding))
import Cardano.Ledger.BaseTypes (Network (Testnet), StrictMaybe (..))
import Cardano.Ledger.Core (TxLevel (..))
import Cardano.Ledger.Credential (Credential (ScriptHashObj))
import Cardano.Ledger.Plutus.Language (Language (PlutusV3))
import CardanoClient (
  QueryPoint (QueryTip),
  SubmitTransactionException,
  waitForUTxO,
 )
import CardanoNode (EndToEndLog (..), runBackend)
import Control.Concurrent.Async (concurrently, mapConcurrently_)
import Control.Lens (cosmos, filtered, (.~), (?~), (^.), (^..), (^?))
import Data.Aeson (Value, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (atKey, key, values, _Integer, _JSON, _String)
import Data.Aeson.Types (parseMaybe)
import Data.ByteString (isInfixOf)
import Data.ByteString qualified as B

import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Hydra.API.HTTPServer (
  DraftCommitTxResponse (..),
  TransactionSubmitted (..),
 )
import Hydra.API.ServerOutput (HeadStatus (..))
import Hydra.Cardano.Api (
  Coin (..),
  Era,
  File (File),
  Key (SigningKey),
  KeyWitnessInCtx (..),
  LedgerProtocolParameters (..),
  PaymentKey,
  Tx,
  TxId (..),
  TxOutDatum,
  UTxO,
  addTxIns,
  addTxInsCollateral,
  addTxOut,
  addTxOuts,
  createAndValidateTransactionBody,
  defaultTxBodyContent,
  fromCtxUTxOTxOut,
  fromLedgerTx,
  getTxBody,
  getTxId,
  lovelaceToValue,
  makeSignedTransaction,
  mkScriptAddress,
  mkScriptDatum,
  mkScriptWitness,
  mkTxIn,
  mkTxOutAutoBalance,
  mkTxOutDatumHash,
  mkVkAddress,
  modifyTxOutValue,
  scriptWitnessInCtx,
  selectLovelace,
  setTxProtocolParams,
  toLedgerData,
  toLedgerExUnits,
  toLedgerScript,
  toLedgerTx,
  toLedgerTxIn,
  toScriptData,
  txOutValue,
  txOuts',
  utxoFromTx,
  writeFileTextEnvelope,
  pattern BuildTxWith,
  pattern KeyWitness,
  pattern PlutusScriptWitness,
  pattern ReferenceScriptNone,
  pattern ScriptWitness,
  pattern TxOut,
  pattern TxOutDatumNone,
 )
import Hydra.Cardano.Api qualified as CAPI
import Hydra.Chain (PostTxError (..))
import Hydra.Chain.Backend (ChainBackend (..), buildTransaction, buildTransactionWithPParams, buildTransactionWithPParams')
import Hydra.Chain.ChainState (ChainSlot (..))
import Hydra.Cluster.Faucet (createOutputAtAddress, seedFromFaucet, seedFromFaucet_)
import Hydra.Cluster.Faucet qualified as Faucet
import Hydra.Cluster.Fixture (Actor (..), actorName, alice, aliceSk, aliceVk, bob, bobSk, bobVk, carol, carolSk, carolVk)
import Hydra.Cluster.Util (Timing (..), chainConfigFor, chainConfigFor', depositTimeout, keysFor, mkTestTiming, mkTestTiming', modifyConfig, nodeStartupBudget, setNetworkId, truncatedDepositPeriod)
import Hydra.Contract.Dummy (dummyRewardingScript, dummyValidatorScript)
import Hydra.Ledger.Cardano (mkSimpleTx, mkTransferTx, unsafeBuildTransaction)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Network qualified as Network
import Hydra.Node.UnsyncedPeriod (defaultUnsyncedPeriodFor, unsyncedPeriodToNominalDiffTime)
import Hydra.Options (CardanoChainConfig (..), ChainBackendOptions (..), ChainConfig (..), DirectOptions (..), RunOptions (..), startChainFrom)
import Hydra.Tx (HeadId (..), IsTx (balance), Party, txId)
import Hydra.Tx.ContestationPeriod qualified as CP
import Hydra.Tx.Crypto (getVerificationKey, signTx)
import Hydra.Tx.Deposit (constructDepositUTxO)
import Hydra.Tx.Secret (Secret, mkSecret)
import Hydra.Tx.Utils (verificationKeyToOnChainId)
import HydraNode (
  HydraClient (..),
  HydraNodePorts (..),
  allocateHydraNodePortsFor,
  getProtocolParameters,
  getSnapshotConfirmed,
  getSnapshotUTxO,
  input,
  output,
  postDecommit,
  prepareHydraNode,
  requestCommitTx,
  scaledFailAfter,
  send,
  waitFor,
  waitForAllMatch,
  waitForNodesConnected,
  waitForNodesDisconnected,
  waitForNodesSynced,
  waitForSnapshotUTxO,
  waitMatch,
  withConnectionToNode,
  withHydraCluster,
  withHydraNode,
  withHydraNodeCatchingUp,
  withPreparedHydraNode,
  withPreparedHydraNodeWithEnv,
  withSoloHydraNode,
  withSoloHydraNodeCatchingUp,
  withUnsyncedHydraNode,
  withUnsyncedSoloHydraNode,
 )
import Network.HTTP.Conduit (parseUrlThrow)
import Network.HTTP.Conduit qualified as L
import Network.HTTP.Req (
  HttpException (VanillaHttpException),
  JsonResponse,
  Option,
  POST (POST),
  ReqBodyJson (ReqBodyJson),
  defaultHttpConfig,
  http,
  port,
  req,
  responseBody,
  runReq,
  (/:),
 )
import Network.HTTP.Simple (getResponseBody, httpJSON, setRequestBodyJSON)
import System.FilePath ((</>))
import System.Process (callProcess)
import Test.Hydra.Ledger.Cardano.Fixtures (maxTxExecutionUnits)
import Test.Hydra.Tx.Fixture (testNetworkId)
import Test.Hydra.Tx.Gen (genDatum, genKeyPair, genTxOutWithReferenceScript)
import Test.QuickCheck (Positive, elements, generate)

oneOfThreeNodesStopsForAWhile :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
oneOfThreeNodesStopsForAWhile :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
oneOfThreeNodesStopsForAWhile Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  let clients :: [Actor]
clients = [Actor
Alice, Actor
Bob, Actor
Carol]
  [(VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
aliceCardanoSk), (VerificationKey PaymentKey
bobCardanoVk, Secret (SigningKey PaymentKey)
_), (VerificationKey PaymentKey
carolCardanoVk, Secret (SigningKey PaymentKey)
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey)))
-> IO
     [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Actor]
clients Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk Lovelace
100_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)
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
carolCardanoVk Lovelace
100_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)
  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
  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
  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 [Actor
Bob, Actor
Carol] 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

  ChainConfig
bobChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Carol] 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

  ChainConfig
carolChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Carol String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Bob] 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
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2, Int
3]
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk, VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    UTxO
aliceUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk (Lovelace -> Value
lovelaceToValue Lovelace
2_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)
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
carolChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        -- Init & open head
        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.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2, HydraClient
n3] ((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, Party
bob, Party
carol])

        -- Alice deposits something
        Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 UTxO
aliceUTxO
        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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1, HydraClient
n2, HydraClient
n3] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]

        -- Perform a simple transaction from alice to herself
        UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n1
        Tx
tx <- NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo Secret (SigningKey PaymentKey)
aliceCardanoSk VerificationKey PaymentKey
aliceCardanoVk
        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
tx]

        -- Everyone confirms it (snapshot 2 = after deposit snapshot 1 + this tx)
        NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
200 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2, HydraClient
n3] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
          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
"snapshot" Getting (First Value) Value Value
-> Getting (First Value) Value Value
-> Getting (First Value) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"number" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (Integer
2 :: Integer))

      -- Carol disconnects and the others observe it
      -- waitForAllMatch (100 * blockTime) [n1, n2] $ \v -> do
      --   guard $ v ^? key "tag" == Just "PeerDisconnected"

      -- Alice never-the-less submits a transaction
      UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n1
      Tx
tx <- NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo Secret (SigningKey PaymentKey)
aliceCardanoSk VerificationKey PaymentKey
aliceCardanoVk
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
tx]

      -- Carol reconnects, and then the snapshot can be confirmed
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
carolChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        -- Note: We can't use `waitForAlMatch` here as it expects them to
        -- emit the exact same datatype; but Carol will be behind in sequence
        -- numbers as she was offline.
        ((HydraClient -> IO ()) -> [HydraClient] -> IO ())
-> [HydraClient] -> (HydraClient -> IO ()) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HydraClient -> IO ()) -> [HydraClient] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ [HydraClient
n1, HydraClient
n2, HydraClient
n3] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n ->
          NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
200 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
            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
"snapshot" Getting (First Value) Value Value
-> Getting (First Value) Value Value
-> Getting (First Value) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"number" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (Integer
3 :: Integer))
            -- Just check that everyone signed it.
            let sigs :: [Value]
sigs = Value
v Value -> Getting (Endo [Value]) Value Value -> [Value]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"signatures" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"multiSignature" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Value]) Value Value
forall t. AsValue t => IndexedTraversal' Int t Value
IndexedTraversal' Int Value Value
values
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
sigs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
 where
  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

restartedNodeCanObserveCommitTx :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
restartedNodeCanObserveCommitTx :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
restartedNodeCanObserveCommitTx Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  let clients :: [Actor]
clients = [Actor
Alice, Actor
Bob]
  [(VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_), (VerificationKey PaymentKey
bobCardanoVk, Secret (SigningKey PaymentKey)
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey)))
-> IO
     [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Actor]
clients Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk Lovelace
100_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)

  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
  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
  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 [Actor
Bob] 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

  ChainConfig
bobChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] 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
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2]
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    HeadId
headId <- Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO HeadId)
-> IO HeadId
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO HeadId) -> IO HeadId)
-> (HydraClient -> IO HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
      -- XXX: might need to tweak the wait time
      NominalDiffTime
-> [HydraClient] -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 [HydraClient
n1, HydraClient
n2] ((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, Party
bob])

    -- n1 does a deposit while n2 is down
    UTxO
depositUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk (Lovelace -> Value
lovelaceToValue Lovelace
2_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)
    Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 UTxO
depositUTxO
    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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx
    NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
10 HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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"
      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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
      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
"utxoToCommit" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (UTxO -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO
depositUTxO)

    -- n2 is back and does observe the deposit
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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
n2 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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"
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
        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
"utxoToCommit" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (UTxO -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO
depositUTxO)

resumeFromLatestKnownPoint :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
resumeFromLatestKnownPoint :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
resumeFromLatestKnownPoint Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  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
  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
  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

  ChainSlot
chainSlot :: ChainSlot <-
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO ChainSlot)
-> IO ChainSlot
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNodeCatchingUp Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO ChainSlot) -> IO ChainSlot)
-> (HydraClient -> IO ChainSlot) -> IO ChainSlot
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 ->
      -- 'currentSlot' is fed from chain Ticks after start up, so wait for it
      -- to move off 0 instead of sampling it once.
      ChainSlot -> HydraClient -> IO ChainSlot
waitForGreetingsSlotPast (Natural -> ChainSlot
ChainSlot Natural
0) HydraClient
n1

  ChainSlot
chainSlot' <-
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO ChainSlot)
-> IO ChainSlot
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNodeCatchingUp Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO ChainSlot) -> IO ChainSlot)
-> (HydraClient -> IO ChainSlot) -> IO ChainSlot
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 ->
      -- The restarted node must progress past the slot observed before the
      -- restart.
      ChainSlot -> HydraClient -> IO ChainSlot
waitForGreetingsSlotPast ChainSlot
chainSlot HydraClient
n1

  ChainSlot
chainSlot ChainSlot -> (ChainSlot -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
< ChainSlot
chainSlot')

  -- Deterministic evidence for the property under test: the restart decided
  -- to start at a point at or after the previously observed slot (the tip
  -- for this idle node), never in a genesis replay. The chain layer traces
  -- its decision on start up.
  ChainSlot
decisionSlot <- String -> IO ChainSlot
lastStartingDecisionSlot (String
workDir String -> String -> String
</> String
"logs" String -> String -> String
</> String
"hydra-node-1.log")
  ChainSlot
decisionSlot ChainSlot -> (ChainSlot -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
>= ChainSlot
chainSlot)
 where
  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

  -- Poll 'Greetings' via fresh connections until 'currentSlot' moved past the
  -- given slot. Greetings carries the slot sampled at connection time, so a
  -- fresh connection per probe is needed.
  waitForGreetingsSlotPast :: ChainSlot -> HydraClient -> IO ChainSlot
  waitForGreetingsSlotPast :: ChainSlot -> HydraClient -> IO ChainSlot
waitForGreetingsSlotPast ChainSlot
lowerBound HydraClient{Int
hydraNodeId :: Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId, Host
apiHost :: Host
$sel:apiHost:HydraClient :: HydraClient -> Host
apiHost, Maybe PortNumber
monitoringPort :: Maybe PortNumber
$sel:monitoringPort:HydraClient :: HydraClient -> Maybe PortNumber
monitoringPort} =
    NominalDiffTime -> IO ChainSlot -> IO ChainSlot
forall a. HasCallStack => NominalDiffTime -> IO a -> IO a
scaledFailAfter NominalDiffTime
60 IO ChainSlot
go
   where
    go :: IO ChainSlot
go = do
      ChainSlot
slot <- Tracer IO HydraNodeLog
-> Int
-> Host
-> Maybe PortNumber
-> (HydraClient -> IO ChainSlot)
-> IO ChainSlot
forall a.
Tracer IO HydraNodeLog
-> Int -> Host -> Maybe PortNumber -> (HydraClient -> IO a) -> IO a
withConnectionToNode Tracer IO HydraNodeLog
hydraTracer Int
hydraNodeId Host
apiHost Maybe PortNumber
monitoringPort ((HydraClient -> IO ChainSlot) -> IO ChainSlot)
-> (HydraClient -> IO ChainSlot) -> IO ChainSlot
forall a b. (a -> b) -> a -> b
$ \HydraClient
n ->
        NominalDiffTime
-> HydraClient -> (Value -> Maybe ChainSlot) -> IO ChainSlot
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
20 HydraClient
n ((Value -> Maybe ChainSlot) -> IO ChainSlot)
-> (Value -> Maybe ChainSlot) -> IO ChainSlot
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
"Greetings"
          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
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadStatus -> Value
forall a. ToJSON a => a -> Value
toJSON HeadStatus
Idle)
          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
"currentSlot" Maybe Value -> (Value -> Maybe ChainSlot) -> Maybe ChainSlot
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 ChainSlot) -> Value -> Maybe ChainSlot
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser ChainSlot
forall a. FromJSON a => Value -> Parser a
parseJSON
      if ChainSlot
slot ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
> ChainSlot
lowerBound then ChainSlot -> IO ChainSlot
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainSlot
slot else DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.2 IO () -> IO ChainSlot -> IO ChainSlot
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ChainSlot
go

  -- The slot of the last 'StartingChainDecision' in the node log. Searches
  -- structurally so wrapping of the chain trace in the node's log envelope
  -- does not matter; a decision without a slot (genesis) contributes nothing.
  lastStartingDecisionSlot :: FilePath -> IO ChainSlot
  lastStartingDecisionSlot :: String -> IO ChainSlot
lastStartingDecisionSlot String
logFile = do
    [Text]
logLines <- Text -> [Text]
forall t. IsText t "lines" => t -> [t]
lines (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 @Text (ByteString -> [Text]) -> IO ByteString -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBS String
logFile
    let decisionSlots :: [Integer]
decisionSlots =
          [ Integer
slot
          | Text
l <- [Text]
logLines
          , Just (Value
v :: Aeson.Value) <- [ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
l)]
          , Value
decision <- Value
v Value -> Getting (Endo [Value]) Value Value -> [Value]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Value]) Value Value
forall a. Plated a => Fold a a
Fold Value Value
cosmos Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Bool) -> Getting (Endo [Value]) Value Value
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered (\Value
sub -> Value
sub 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
"StartingChainDecision")
          , Integer
slot <- Value
decision Value -> Getting (Endo [Integer]) Value Integer -> [Integer]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Value -> Const (Endo [Integer]) Value)
-> Value -> Const (Endo [Integer]) Value
forall a. Plated a => Fold a a
Fold Value Value
cosmos ((Value -> Const (Endo [Integer]) Value)
 -> Value -> Const (Endo [Integer]) Value)
-> Getting (Endo [Integer]) Value Integer
-> Getting (Endo [Integer]) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"slot" ((Value -> Const (Endo [Integer]) Value)
 -> Value -> Const (Endo [Integer]) Value)
-> Getting (Endo [Integer]) Value Integer
-> Getting (Endo [Integer]) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Integer]) Value Integer
forall t. AsNumber t => Prism' t Integer
Prism' Value Integer
_Integer
          ]
    case [Integer] -> Maybe (NonEmpty Integer)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Integer]
decisionSlots of
      Just NonEmpty Integer
slots -> ChainSlot -> IO ChainSlot
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainSlot -> IO ChainSlot) -> ChainSlot -> IO ChainSlot
forall a b. (a -> b) -> a -> b
$ Natural -> ChainSlot
ChainSlot (Integer -> Natural
forall a. Num a => Integer -> a
fromInteger (NonEmpty Integer -> Integer
forall (f :: * -> *) a. IsNonEmpty f a a "last" => f a -> a
last NonEmpty Integer
slots))
      Maybe (NonEmpty Integer)
Nothing -> String -> IO ChainSlot
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String
"no StartingChainDecision with a slot found in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
logFile)

restartedNodeCanClose :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
restartedNodeCanClose :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
restartedNodeCanClose Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
100_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
  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
      -- we delibelately do not start from a chain point here to highlight the
      -- need for persistence
      IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\CardanoChainConfig
config -> CardanoChainConfig
config{startChainFrom = Nothing})

  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
  HeadId
headId1 <- Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO HeadId)
-> IO HeadId
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) -> IO HeadId)
-> (HydraClient -> IO HeadId) -> IO HeadId
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" []
    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])

  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withUnsyncedSoloHydraNode Tracer IO HydraNodeLog
hydraTracer 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
    -- Also expect to see past server outputs replayed
    HeadId
headId2 <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
10) 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])
    HeadId
headId1 HeadId -> HeadId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` HeadId
headId2
    -- The node rejects inputs while catching up, and under load a restart can
    -- start out more than 'unsyncedPeriod' behind; wait until it reports
    -- itself synced before closing.
    HydraClient -> IO ()
waitUntilSynced HydraClient
n1
    -- Heads now open directly, so we close instead of abort
    HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []
    NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
20 HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"HeadIsClosed"
      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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId2)
  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withUnsyncedSoloHydraNode Tracer IO HydraNodeLog
hydraTracer 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
    NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
10) HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"Greetings"
      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
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
"Closed"
      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
"me" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Party -> Value
forall a. ToJSON a => a -> Value
toJSON Party
alice)
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (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
"hydraNodeVersion")
 where
  -- Poll 'Greetings' via fresh connections until the node reports Synced;
  -- Greetings carries the status sampled at connection time.
  waitUntilSynced :: HydraClient -> IO ()
waitUntilSynced HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId, Host
$sel:apiHost:HydraClient :: HydraClient -> Host
apiHost :: Host
apiHost, Maybe PortNumber
$sel:monitoringPort:HydraClient :: HydraClient -> Maybe PortNumber
monitoringPort :: Maybe PortNumber
monitoringPort} =
    NominalDiffTime -> IO () -> IO ()
forall a. HasCallStack => NominalDiffTime -> IO a -> IO a
scaledFailAfter NominalDiffTime
60 IO ()
go
   where
    go :: IO ()
go = do
      Text
synced <- Tracer IO HydraNodeLog
-> Int
-> Host
-> Maybe PortNumber
-> (HydraClient -> IO Text)
-> IO Text
forall a.
Tracer IO HydraNodeLog
-> Int -> Host -> Maybe PortNumber -> (HydraClient -> IO a) -> IO a
withConnectionToNode ((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) Int
hydraNodeId Host
apiHost Maybe PortNumber
monitoringPort ((HydraClient -> IO Text) -> IO Text)
-> (HydraClient -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \HydraClient
n ->
        NominalDiffTime -> HydraClient -> (Value -> Maybe Text) -> IO Text
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
20 HydraClient
n ((Value -> Maybe Text) -> IO Text)
-> (Value -> Maybe Text) -> IO Text
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
"Greetings"
          Value
v Value -> Getting (First Text) Value Text -> Maybe Text
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
"chainSyncedStatus" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
synced Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"InSync") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.2 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
go

nodeReObservesOnChainTxs :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
nodeReObservesOnChainTxs :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
nodeReObservesOnChainTxs Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
100_000_000
  Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Bob Lovelace
100_000_000
  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
  -- Start hydra-node on chain tip
  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
  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

  -- NOTE: Adapt periods to block times
  let depositPeriod :: DepositPeriod
depositPeriod = NominalDiffTime -> DepositPeriod
truncatedDepositPeriod (NominalDiffTime -> DepositPeriod)
-> NominalDiffTime -> DepositPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
50 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime
  let timing :: Timing
timing = Timing{NominalDiffTime
blockTime :: NominalDiffTime
$sel:blockTime:Timing :: NominalDiffTime
blockTime, $sel:contestationPeriod:Timing :: ContestationPeriod
contestationPeriod = NominalDiffTime -> ContestationPeriod
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (NominalDiffTime -> ContestationPeriod)
-> NominalDiffTime -> ContestationPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:Timing :: DepositPeriod
depositPeriod, $sel:depositActivation:Timing :: DepositPeriod
depositActivation = DepositPeriod
depositPeriod}
  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 [Actor
Bob] Timing
timing
      IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\CardanoChainConfig
config -> CardanoChainConfig
config{startChainFrom = Nothing})

  ChainConfig
bobChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] Timing
timing
      IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\CardanoChainConfig
config -> CardanoChainConfig
config{startChainFrom = Nothing})

  (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
aliceCardanoSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice
  UTxO
commitUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk (Lovelace -> Value
lovelaceToValue Lovelace
5_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)

  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

  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2]
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    (HeadId
headId', UTxO
decrementOuts) <- Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO (HeadId, UTxO))
-> IO (HeadId, UTxO)
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO (HeadId, UTxO)) -> IO (HeadId, UTxO))
-> (HydraClient -> IO (HeadId, UTxO)) -> IO (HeadId, UTxO)
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> 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
20 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, Party
bob])
      HeadId
_ <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n2 ((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, Party
bob])

      Response Tx
resp <-
        String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
          IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO
commitUTxO
            IO Request -> (Request -> IO (Response Tx)) -> IO (Response Tx)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response Tx)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON

      let depositTransaction :: Tx
depositTransaction = Response Tx -> Tx
forall a. Response a -> a
getResponseBody Response Tx
resp :: Tx
      let tx :: Tx
tx = Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
aliceCardanoSk Tx
depositTransaction

      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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx

      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1, HydraClient
n2] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"CommitApproved" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"utxoToCommit" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
commitUTxO]

      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1, HydraClient
n2] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx)]

      HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO (Timing -> NominalDiffTime
depositTimeout Timing
timing) HydraClient
n1 UTxO
commitUTxO

      let aliceAddress :: AddressInEra Era
aliceAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
aliceCardanoVk

      Tx
decommitTx <- do
        let (TxIn
i, TxOut CtxUTxO Era
o) = [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
commitUTxO
        (TxBodyError -> IO Tx)
-> (Tx -> IO Tx) -> Either TxBodyError Tx -> IO Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO Tx
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Tx)
-> (TxBodyError -> String) -> TxBodyError -> IO Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show) Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TxBodyError Tx -> IO Tx) -> Either TxBodyError Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$
          (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra Era, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
i, TxOut CtxUTxO Era
o) (AddressInEra Era
aliceAddress, TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
o) Secret (SigningKey PaymentKey)
aliceCardanoSk

      let decommitUTxO :: UTxO
decommitUTxO = Tx -> UTxO
utxoFromTx Tx
decommitTx
          decommitTxId :: TxIdType Tx
decommitTxId = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
decommitTx

      -- Sometimes use websocket, sometimes use HTTP
      IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> (Gen (IO ()) -> IO (IO ())) -> Gen (IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (IO ()) -> IO (IO ())
forall a. Gen a -> IO a
generate (Gen (IO ()) -> IO ()) -> Gen (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        [IO ()] -> Gen (IO ())
forall a. HasCallStack => [a] -> Gen a
elements
          [ HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Decommit" [Key
"decommitTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
decommitTx]
          , HydraClient -> Tx -> IO ()
postDecommit HydraClient
n1 Tx
decommitTx
          ]

      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n1, HydraClient
n2] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"DecommitRequested" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"decommitTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
decommitTx, Key
"utxoToDecommit" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
decommitUTxO]
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n1, HydraClient
n2] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"DecommitApproved" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"decommitTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TxId
TxIdType Tx
decommitTxId, Key
"utxoToDecommit" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
decommitUTxO]

      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainBackendOptions -> UTxO -> IO ()
waitForUTxO ChainBackendOptions
opts UTxO
decommitUTxO

      UTxO
distributedUTxO <- NominalDiffTime
-> [HydraClient] -> (Value -> Maybe UTxO) -> IO UTxO
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 [HydraClient
n1, HydraClient
n2] ((Value -> Maybe UTxO) -> IO UTxO)
-> (Value -> Maybe UTxO) -> IO UTxO
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
"DecommitFinalized"
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
        Value
v Value -> Getting (First UTxO) Value UTxO -> Maybe UTxO
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
"distributedUTxO" ((Value -> Const (First UTxO) Value)
 -> Value -> Const (First UTxO) Value)
-> Getting (First UTxO) Value UTxO
-> Getting (First UTxO) Value UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTxO) Value UTxO
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTxO UTxO
_JSON

      Bool -> IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UTxO
distributedUTxO UTxO -> [TxOut CtxUTxO Era] -> Bool
forall era. UTxO era -> [TxOut CtxUTxO era] -> Bool
`UTxO.containsOutputs` UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs (Tx -> UTxO
utxoFromTx Tx
decommitTx)

      (HeadId, UTxO) -> IO (HeadId, UTxO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadId
headId, UTxO
decommitUTxO)

    ChainConfig
bobChainConfigFromTip <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] Timing
timing
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\CardanoChainConfig
config -> CardanoChainConfig
config{startChainFrom = Just tip})

    String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
String -> (String -> m r) -> m r
withTempDir String
"blank-state" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
tmpDir -> do
      String -> [String] -> IO ()
callProcess String
"cp" [String
"-r", String
workDir String -> String -> String
</> String
"state-2", String
tmpDir]
      String -> [String] -> IO ()
callProcess String
"rm" [String
"-rf", String
tmpDir String -> String -> String
</> String
"state-2" String -> String -> String
</> String
"state*"]
      String -> [String] -> IO ()
callProcess String
"rm" [String
"-rf", String
tmpDir String -> String -> String
</> String
"state-2" String -> String -> String
</> String
"last-known-revision"]
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfigFromTip String
tmpDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
        -- Also expect to see past server outputs replayed
        HeadId
headId2 <- 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 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
10) HydraClient
n2 ((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, Party
bob])
        HeadId
headId2 HeadId -> HeadId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` HeadId
headId'

        UTxO
distributedUTxO <- NominalDiffTime
-> [HydraClient] -> (Value -> Maybe UTxO) -> IO UTxO
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
5 [HydraClient
n2] ((Value -> Maybe UTxO) -> IO UTxO)
-> (Value -> Maybe UTxO) -> IO UTxO
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
"DecommitFinalized"
          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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId2)
          Value
v Value -> Getting (First UTxO) Value UTxO -> Maybe UTxO
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
"distributedUTxO" ((Value -> Const (First UTxO) Value)
 -> Value -> Const (First UTxO) Value)
-> Getting (First UTxO) Value UTxO
-> Getting (First UTxO) Value UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTxO) Value UTxO
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTxO UTxO
_JSON

        Bool -> IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UTxO
distributedUTxO UTxO -> [TxOut CtxUTxO Era] -> Bool
forall era. UTxO era -> [TxOut CtxUTxO era] -> Bool
`UTxO.containsOutputs` UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
decrementOuts

        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []

        UTCTime
deadline' <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n2 ((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
"HeadIsClosed"
          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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId')
          Value
v Value -> Getting (First UTCTime) Value UTCTime -> Maybe UTCTime
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
"contestationDeadline" ((Value -> Const (First UTCTime) Value)
 -> Value -> Const (First UTCTime) Value)
-> Getting (First UTCTime) Value UTCTime
-> Getting (First UTCTime) Value UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTCTime) Value UTCTime
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTCTime UTCTime
_JSON
        NominalDiffTime
remainingTime <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline' (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
remainingTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"ReadyToFanout" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId']
        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Fanout" []

        NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ HeadId -> UTxO -> Value -> Maybe ()
headIsFinalizedWith HeadId
headId' UTxO
forall a. Monoid a => a
mempty

-- | Step through the full life cycle of a Hydra Head with only a single
-- participant. This scenario is also used by the smoke test run via the
-- `hydra-cluster` executable.
singlePartyHeadFullLifeCycle ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  IO ()
singlePartyHeadFullLifeCycle :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
singlePartyHeadFullLifeCycle 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
55_000_000
    -- Start hydra-node on chain tip
    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
    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
    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
    let timing :: Timing
timing = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
    let Timing{$sel:depositPeriod:Timing :: Timing -> DepositPeriod
depositPeriod = DepositPeriod
timingDepositPeriod, $sel:depositActivation:Timing :: Timing -> DepositPeriod
depositActivation = DepositPeriod
timingDepositActivation} = Timing
timing
    ContestationPeriod
contestationPeriod <- NominalDiffTime -> IO ContestationPeriod
forall (m :: * -> *).
MonadFail m =>
NominalDiffTime -> m ContestationPeriod
CP.fromNominalDiffTime (NominalDiffTime -> IO ContestationPeriod)
-> NominalDiffTime -> IO ContestationPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
chainConfigFor' Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositPeriod
timingDepositPeriod DepositPeriod
timingDepositActivation
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\CardanoChainConfig
config -> CardanoChainConfig
config{startChainFrom = Just tip})
          (ChainConfig -> ChainConfig)
-> (ChainConfig -> ChainConfig) -> ChainConfig -> ChainConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkId -> ChainConfig -> ChainConfig
setNetworkId NetworkId
networkId

    (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
aliceCardanoSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice
    let aliceAddress :: AddressInEra Era
aliceAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
aliceCardanoVk

    -- Prepare deposit payload
    (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
    let depositAmount :: Lovelace
depositAmount = Lovelace
10_000_000
    UTxO
depositUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
depositAmount) ((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)
    let changeAddress :: AddressInEra Era
changeAddress = forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress @Era NetworkId
networkId VerificationKey PaymentKey
walletVk
    let (TxIn
i, TxOut CtxUTxO Era
o) = [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
depositUTxO
    let witness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
witness = 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
    let blueprint :: Tx
blueprint =
          HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
            TxBodyContent BuildTx
defaultTxBodyContent
              TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(TxIn
i, BuildTxWith BuildTx (Witness WitCtxTxIn)
witness)]
              TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxOut CtxTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxOut CtxTx era
-> TxBodyContent build era -> TxBodyContent build era
addTxOut (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO Era
o)
    let clientPayload :: Value
clientPayload =
          [Pair] -> Value
Aeson.object
            [ Key
"blueprintTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
blueprint
            , Key
"utxo" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
depositUTxO
            , Key
"changeAddress" Key -> AddressInEra Era -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AddressInEra Era
changeAddress
            ]

    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
      -- Open head
      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
30 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])
      -- Deposit UTxO
      JsonResponse Tx
res <-
        HttpConfig -> Req (JsonResponse Tx) -> IO (JsonResponse Tx)
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req (JsonResponse Tx) -> IO (JsonResponse Tx))
-> Req (JsonResponse Tx) -> IO (JsonResponse Tx)
forall a b. (a -> b) -> a -> b
$
          POST
-> Url 'Http
-> ReqBodyJson Value
-> Proxy (JsonResponse Tx)
-> Option 'Http
-> Req (JsonResponse Tx)
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST (Text -> Url 'Http
http Text
"127.0.0.1" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"commit") (Value -> ReqBodyJson Value
forall a. a -> ReqBodyJson a
ReqBodyJson Value
clientPayload) (Proxy (JsonResponse Tx)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse Tx)) (HydraClient -> Option 'Http
forall (scheme :: Scheme). HydraClient -> Option scheme
hydraApiPort HydraClient
n1)

      let tx :: Tx
tx = SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk (Tx -> Tx) -> Tx -> Tx
forall a b. (a -> b) -> a -> b
$ JsonResponse Tx -> HttpResponseBody (JsonResponse Tx)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody JsonResponse Tx
res
      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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx

      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (Timing -> NominalDiffTime
depositTimeout Timing
timing) HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"CommitFinalized"
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
        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
"depositTxId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (TxId -> Value
forall a. ToJSON a => a -> Value
toJSON (TxId -> Value) -> TxId -> Value
forall a b. (a -> b) -> a -> b
$ TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx))
        () -> Maybe ()
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n1
      Tx
l2tx <- NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
walletSk) VerificationKey PaymentKey
aliceCardanoVk
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
l2tx]
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
        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
"snapshot" Getting (First Value) Value Value
-> Getting (First Value) Value Value
-> Getting (First Value) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"number" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (Integer
2 :: Integer))

      UTxO
utxo' <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n1

      Tx
decommitTx <- do
        let (TxIn
input', TxOut CtxUTxO Era
output') = [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
utxo'
        (TxBodyError -> IO Tx)
-> (Tx -> IO Tx) -> Either TxBodyError Tx -> IO Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO Tx
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Tx)
-> (TxBodyError -> String) -> TxBodyError -> IO Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show) Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TxBodyError Tx -> IO Tx) -> Either TxBodyError Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$
          (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra Era, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
input', TxOut CtxUTxO Era
output') (AddressInEra Era
aliceAddress, TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
o) Secret (SigningKey PaymentKey)
aliceCardanoSk

      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Decommit" [Key
"decommitTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
decommitTx]

      UTxO
distributedUTxO <- NominalDiffTime
-> [HydraClient] -> (Value -> Maybe UTxO) -> IO UTxO
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
50 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1] ((Value -> Maybe UTxO) -> IO UTxO)
-> (Value -> Maybe UTxO) -> IO UTxO
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
"DecommitFinalized"
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
        Value
v Value -> Getting (First UTxO) Value UTxO -> Maybe UTxO
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
"distributedUTxO" ((Value -> Const (First UTxO) Value)
 -> Value -> Const (First UTxO) Value)
-> Getting (First UTxO) Value UTxO
-> Getting (First UTxO) Value UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTxO) Value UTxO
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTxO UTxO
_JSON

      Bool -> IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UTxO
distributedUTxO UTxO -> [TxOut CtxUTxO Era] -> Bool
forall era. UTxO era -> [TxOut CtxUTxO era] -> Bool
`UTxO.containsOutputs` UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs (Tx -> UTxO
utxoFromTx Tx
decommitTx)

      -- Close head
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []

      UTCTime
deadline <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
50 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) 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
"HeadIsClosed"
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
        Value
v Value -> Getting (First UTCTime) Value UTCTime -> Maybe UTCTime
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
"contestationDeadline" ((Value -> Const (First UTCTime) Value)
 -> Value -> Const (First UTCTime) Value)
-> Getting (First UTCTime) Value UTCTime
-> Getting (First UTCTime) Value UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTCTime) Value UTCTime
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTCTime UTCTime
_JSON
      -- Wait for fanout
      NominalDiffTime
remainingTime <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
remainingTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
50 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"ReadyToFanout" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId]
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Fanout" []

      NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
50 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ HeadId -> UTxO -> Value -> Maybe ()
headIsFinalizedWith HeadId
headId UTxO
forall a. Monoid a => a
mempty
    Actor -> IO ()
traceRemainingFunds Actor
Alice
 where
  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

  traceRemainingFunds :: Actor -> IO ()
traceRemainingFunds Actor
actor = do
    (VerificationKey PaymentKey
actorVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
actor
    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
$ QueryPoint -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> VerificationKey PaymentKey -> m UTxO
queryUTxOFor QueryPoint
QueryTip VerificationKey PaymentKey
actorVk
    Tracer IO EndToEndLog -> EndToEndLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO EndToEndLog
tracer RemainingFunds{$sel:actor:ClusterOptions :: String
actor = Actor -> String
actorName Actor
actor, UTxO
utxo :: UTxO
$sel:utxo:ClusterOptions :: UTxO
utxo}

-- | Open a Hydra Head with only a single participant but some arbitrary UTxO
-- committed.
singlePartyOpenAHead ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  Maybe (Positive Natural) ->
  -- | Continuation called when the head is open
  (HydraClient -> Secret (SigningKey PaymentKey) -> HeadId -> IO a) ->
  IO a
singlePartyOpenAHead :: forall a.
Tracer IO EndToEndLog
-> String
-> ChainBackendOptions
-> [TxId]
-> Maybe (Positive Natural)
-> (HydraClient
    -> Secret (SigningKey PaymentKey) -> HeadId -> IO a)
-> IO a
singlePartyOpenAHead Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId Maybe (Positive Natural)
persistenceRotateAfter HydraClient -> Secret (SigningKey PaymentKey) -> HeadId -> IO a
callback =
  (IO a -> IO () -> IO a
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 a -> IO a) -> IO a -> IO a
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
25_000_000
    -- Start hydra-node on chain tip
    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
    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
    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
<&> (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\CardanoChainConfig
config -> CardanoChainConfig
config{startChainFrom = Just tip})

    (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
    let keyPath :: String
keyPath = String
workDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/wallet.sk"
    Either (FileError ()) ()
_ <- File Any 'Out
-> Maybe TextEnvelopeDescr
-> SigningKey PaymentKey
-> IO (Either (FileError ()) ())
forall a content.
HasTextEnvelope a =>
File content 'Out
-> Maybe TextEnvelopeDescr -> a -> IO (Either (FileError ()) ())
writeFileTextEnvelope (String -> File Any 'Out
forall content (direction :: FileDirection).
String -> File content direction
File String
keyPath) Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing SigningKey PaymentKey
walletSk
    Tracer IO EndToEndLog -> EndToEndLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO EndToEndLog
tracer CreatedKey{String
keyPath :: String
$sel:keyPath:ClusterOptions :: String
keyPath}

    UTxO
utxoToDeposit <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
100_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)

    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
    Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1]
    RunOptions
options <- HasCallStack =>
ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] Map Int HydraNodePorts
nodePorts Value -> Value
forall a. a -> a
id
    let options' :: RunOptions
options' = RunOptions
options{persistenceRotateAfter}
    Tracer IO HydraNodeLog
-> String -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> String -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
withPreparedHydraNode Tracer IO HydraNodeLog
hydraTracer String
workDir Int
1 RunOptions
options' ((HydraClient -> IO a) -> IO a) -> (HydraClient -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
      IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => NominalDiffTime -> [HydraClient] -> IO ()
NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesSynced (NominalDiffTime
5 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1]
      -- Initialize & open head
      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])
      -- Deposit funds into head
      Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 UTxO
utxoToDeposit IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk
      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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]

      HydraClient -> Secret (SigningKey PaymentKey) -> HeadId -> IO a
callback HydraClient
n1 (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
walletSk) HeadId
headId

-- | Single hydra-node where the deposit is done using some wallet UTxO.
canDeposit ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  IO ()
canDeposit :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canDeposit 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`
      do
        Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice
        Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
AliceFunds
  )
    (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
25_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
      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
      let hydraNodeId :: Int
hydraNodeId = Int
1
      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
hydraNodeId 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
walletVk, Secret (SigningKey PaymentKey)
walletSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
AliceFunds
        UTxO
utxoToDeposit <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
5_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)

        JsonResponse (DraftCommitTxResponse Tx)
res <-
          HttpConfig
-> Req (JsonResponse (DraftCommitTxResponse Tx))
-> IO (JsonResponse (DraftCommitTxResponse Tx))
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req (JsonResponse (DraftCommitTxResponse Tx))
 -> IO (JsonResponse (DraftCommitTxResponse Tx)))
-> Req (JsonResponse (DraftCommitTxResponse Tx))
-> IO (JsonResponse (DraftCommitTxResponse Tx))
forall a b. (a -> b) -> a -> b
$
            POST
-> Url 'Http
-> ReqBodyJson UTxO
-> Proxy (JsonResponse (DraftCommitTxResponse Tx))
-> Option 'Http
-> Req (JsonResponse (DraftCommitTxResponse Tx))
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req
              POST
POST
              (Text -> Url 'Http
http Text
"127.0.0.1" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"commit")
              (UTxO -> ReqBodyJson UTxO
forall a. a -> ReqBodyJson a
ReqBodyJson UTxO
utxoToDeposit)
              (Proxy (JsonResponse (DraftCommitTxResponse Tx))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse (DraftCommitTxResponse Tx)))
              (HydraClient -> Option 'Http
forall (scheme :: Scheme). HydraClient -> Option scheme
hydraApiPort HydraClient
n1)

        let DraftCommitTxResponse{Tx
commitTx :: Tx
$sel:commitTx:DraftCommitTxResponse :: forall tx. DraftCommitTxResponse tx -> tx
commitTx} = JsonResponse (DraftCommitTxResponse Tx)
-> HttpResponseBody (JsonResponse (DraftCommitTxResponse Tx))
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody JsonResponse (DraftCommitTxResponse Tx)
res
        let depositTx :: Tx
depositTx = Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
walletSk Tx
commitTx
        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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx

        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]
        HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO (Timing -> NominalDiffTime
depositTimeout Timing
timing) HydraClient
n1 UTxO
utxoToDeposit

singlePartyUsesScriptOnL2 ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  IO ()
singlePartyUsesScriptOnL2 :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
singlePartyUsesScriptOnL2 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`
      do
        Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice
        Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
AliceFunds
  )
    (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
250_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
      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
      let hydraNodeId :: Int
hydraNodeId = Int
1
      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
hydraNodeId 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
walletVk, Secret (SigningKey PaymentKey)
walletSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
AliceFunds

        -- Create money on L1
        let commitAmount :: Lovelace
commitAmount = Lovelace
100_000_000
        UTxO
utxoToDeposit <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
commitAmount) ((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)

        -- Deposit it into L2
        Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 UTxO
utxoToDeposit IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
walletSk
        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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx

        -- Check UTxO is present in L2
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]

        PParams ConwayEra
pparams <- HydraClient -> IO (PParams (ShelleyLedgerEra Era))
getProtocolParameters HydraClient
n1
        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

        -- Send the UTxO to a script; in preparation for running the script
        let serializedScript :: PlutusScript
serializedScript = PlutusScript
dummyValidatorScript
        let scriptAddress :: AddressInEra Era
scriptAddress = NetworkId -> PlutusScript -> AddressInEra Era
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript
serializedScript
        let scriptOutput :: TxOut CtxTx Era
scriptOutput =
              PParams (ShelleyLedgerEra Era)
-> AddressInEra Era
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
mkTxOutAutoBalance
                PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pparams
                AddressInEra Era
scriptAddress
                (Lovelace -> Value
lovelaceToValue Lovelace
0)
                (() -> TxOutDatum CtxTx Era
forall era a ctx.
(ToScriptData a, IsAlonzoBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumHash ())
                ReferenceScript Era
ReferenceScriptNone

        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
        case PParams (ShelleyLedgerEra Era)
-> SystemStart
-> EraHistory
-> Set PoolId
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> Maybe PlutusScript
-> Either (TxBodyErrorAutoBalance Era) Tx
buildTransactionWithPParams' PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pparams SystemStart
systemStart EraHistory
eraHistory Set PoolId
stakePools (NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
walletVk) UTxO
utxoToDeposit [] [TxOut CtxTx Era
scriptOutput] Maybe PlutusScript
forall a. Maybe a
Nothing of
          Left TxBodyErrorAutoBalance Era
e -> Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ TxBodyErrorAutoBalance Era -> Text
forall b a. (Show a, IsString b) => a -> b
show TxBodyErrorAutoBalance Era
e
          Right Tx
tx -> do
            let signedL2tx :: Tx
signedL2tx = Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
walletSk Tx
tx
            HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
signedL2tx]

            NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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 ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
                Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
signedL2tx
                  Value -> [Value] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (Value
v Value -> Getting (Endo [Value]) Value Value -> [Value]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshot" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"confirmed" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Value]) Value Value
forall t. AsValue t => IndexedTraversal' Int t Value
IndexedTraversal' Int Value Value
values)

            -- Now, spend the money from the script
            let scriptWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
scriptWitness =
                  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
-> ScriptRedeemer
-> ExecutionUnits
-> ScriptWitness WitCtxTxIn
forall witctx.
PlutusScript
-> ScriptDatum witctx
-> ScriptRedeemer
-> ExecutionUnits
-> ScriptWitness witctx
PlutusScriptWitness
                        PlutusScript
serializedScript
                        (() -> ScriptDatum WitCtxTxIn
forall a. ToScriptData a => a -> ScriptDatum WitCtxTxIn
mkScriptDatum ())
                        (() -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData ())
                        ExecutionUnits
maxTxExecutionUnits

            let txIn :: TxIn
txIn = Tx -> Word -> TxIn
forall era. Tx era -> Word -> TxIn
mkTxIn Tx
signedL2tx Word
0
            let remainder :: TxIn
remainder = Tx -> Word -> TxIn
forall era. Tx era -> Word -> TxIn
mkTxIn Tx
signedL2tx Word
1

            let outAmt :: Value
outAmt = (TxOut CtxTx Era -> Value) -> [TxOut CtxTx Era] -> Value
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx)
            let body :: TxBodyContent BuildTx
body =
                  TxBodyContent BuildTx
defaultTxBodyContent
                    TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(TxIn
txIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
scriptWitness), (TxIn
remainder, 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
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
IsAlonzoBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsCollateral [TxIn
remainder]
                    TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [AddressInEra Era
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript Era -> TxOut ctx
TxOut (NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
walletVk) Value
outAmt TxOutDatum CtxTx Era
forall ctx. TxOutDatum ctx
TxOutDatumNone ReferenceScript Era
ReferenceScriptNone]
                    TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
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 (ShelleyLedgerEra Era) -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pparams)

            -- TODO: Instead of using `createAndValidateTransactionBody`, we
            -- should be able to just construct the Tx with autobalancing via
            -- `buildTransactionWithBody`. Unfortunately this is broken in the
            -- version of cardano-api that we presently use; in a future upgrade
            -- of that library we can try again.
            -- tx' <- either (failure . show) pure =<< buildTransactionWithBody networkId nodeSocket (mkVkAddress networkId walletVk) body utxoToDeposit
            TxBody Era
txBody <- (TxBodyError -> IO (TxBody Era))
-> (TxBody Era -> IO (TxBody Era))
-> Either TxBodyError (TxBody Era)
-> IO (TxBody Era)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO (TxBody Era)
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO (TxBody Era))
-> (TxBodyError -> String) -> TxBodyError -> IO (TxBody Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show) TxBody Era -> IO (TxBody Era)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBodyContent BuildTx -> Either TxBodyError (TxBody Era)
createAndValidateTransactionBody TxBodyContent BuildTx
body)

            let spendTx' :: Tx
spendTx' = [KeyWitness Era] -> TxBody Era -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody Era
txBody
                spendTx :: Tx
spendTx = Tx TopTx (ShelleyLedgerEra Era) -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx (ShelleyLedgerEra Era) -> Tx)
-> Tx TopTx (ShelleyLedgerEra Era) -> Tx
forall a b. (a -> b) -> a -> b
$ PParams ConwayEra
-> [Language] -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall ppera txera.
(AlonzoEraPParams ppera, AlonzoEraTxWits txera,
 AlonzoEraTxBody txera, EraTx txera) =>
PParams ppera -> [Language] -> Tx TopTx txera -> Tx TopTx txera
recomputeIntegrityHash PParams ConwayEra
pparams [Language
PlutusV3] (Tx -> Tx TopTx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
spendTx')
            let signedTx :: Tx
signedTx = Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
walletSk Tx
spendTx

            HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
signedTx]

            NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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 ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
                Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
signedTx
                  Value -> [Value] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (Value
v Value -> Getting (Endo [Value]) Value Value -> [Value]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshot" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"confirmed" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Value]) Value Value
forall t. AsValue t => IndexedTraversal' Int t Value
IndexedTraversal' Int Value Value
values)

            -- And check that we can close and fanout the head successfully
            HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []
            UTCTime
deadline <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
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 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
"HeadIsClosed"
              Value
v Value -> Getting (First UTCTime) Value UTCTime -> Maybe UTCTime
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
"contestationDeadline" ((Value -> Const (First UTCTime) Value)
 -> Value -> Const (First UTCTime) Value)
-> Getting (First UTCTime) Value UTCTime
-> Getting (First UTCTime) Value UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTCTime) Value UTCTime
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTCTime UTCTime
_JSON
            NominalDiffTime
remainingTime <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
            HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
remainingTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
              Text -> [Pair] -> Value
output Text
"ReadyToFanout" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId]
            HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Fanout" []
            NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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 ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
              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
"HeadIsFinalized"

            -- Assert final wallet balance
            (UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Value) -> IO (UTxOType Tx) -> IO Value
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))
-> IO (UTxOType Tx)
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
walletVk))
              IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue Lovelace
commitAmount

-- | Open a head and run a script using 'Rewarding' script purpose and a zero
-- lovelace withdrawal.
singlePartyUsesWithdrawZeroTrick :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
singlePartyUsesWithdrawZeroTrick :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
singlePartyUsesWithdrawZeroTrick Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId =
  -- Seed/return fuel
  IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
250_000_000) (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
    -- Seed/return funds
    (VerificationKey PaymentKey
walletVk, Secret (SigningKey PaymentKey)
walletSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
AliceFunds
    IO UTxO -> (UTxO -> IO ()) -> (UTxO -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
      (ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
100_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))
      (\UTxO
_ -> Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
AliceFunds)
      ((UTxO -> IO ()) -> IO ()) -> (UTxO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UTxO
utxoToDeposit -> do
        -- Start hydra-node and open a head
        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
        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
        let hydraNodeId :: Int
hydraNodeId = Int
1
        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
        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
        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
hydraNodeId 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])
          -- Deposit funds into head
          Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 UTxO
utxoToDeposit IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
walletSk
          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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx
          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]

          -- Prepare a tx that re-spends everything owned by walletVk
          PParams ConwayEra
pparams <- HydraClient -> IO (PParams (ShelleyLedgerEra Era))
getProtocolParameters HydraClient
n1
          let change :: AddressInEra Era
change = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
walletVk
          Right Tx
tx <- ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Either (TxBodyErrorAutoBalance Era) Tx))
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts (PParams (ShelleyLedgerEra Era)
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
PParams (ShelleyLedgerEra Era)
-> AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> Maybe PlutusScript
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pparams AddressInEra Era
change UTxO
utxoToDeposit [] [] Maybe PlutusScript
forall a. Maybe a
Nothing)

          -- Modify the tx to run a script via the withdraw 0 trick
          let redeemer :: Data ConwayEra
redeemer = ScriptRedeemer -> Data ConwayEra
forall era. Era era => ScriptRedeemer -> Data era
toLedgerData (ScriptRedeemer -> Data ConwayEra)
-> ScriptRedeemer -> Data ConwayEra
forall a b. (a -> b) -> a -> b
$ () -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData ()
              exUnits :: ExUnits
exUnits = ExecutionUnits -> ExUnits
toLedgerExUnits ExecutionUnits
maxTxExecutionUnits
              rewardAccount :: AccountAddress
rewardAccount = Network -> AccountId -> AccountAddress
AccountAddress Network
Testnet (Credential Staking -> AccountId
AccountId (ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash))
              scriptHash :: ScriptHash
scriptHash = Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script ConwayEra
AlonzoScript ConwayEra
script
              script :: AlonzoScript (ShelleyLedgerEra Era)
script = forall lang era.
ToAlonzoScript lang era =>
PlutusScript lang -> AlonzoScript (ShelleyLedgerEra era)
toLedgerScript @_ @Era PlutusScript
dummyRewardingScript
          let tx' :: Tx
tx' =
                Tx TopTx (ShelleyLedgerEra Era) -> Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx TopTx (ShelleyLedgerEra Era) -> Tx)
-> Tx TopTx (ShelleyLedgerEra Era) -> Tx
forall a b. (a -> b) -> a -> b
$
                  PParams ConwayEra
-> [Language]
-> Tx TopTx (ShelleyLedgerEra Era)
-> Tx TopTx (ShelleyLedgerEra Era)
forall ppera txera.
(AlonzoEraPParams ppera, AlonzoEraTxWits txera,
 AlonzoEraTxBody txera, EraTx txera) =>
PParams ppera -> [Language] -> Tx TopTx txera -> Tx TopTx txera
recomputeIntegrityHash PParams ConwayEra
pparams [Language
PlutusV3] (Tx TopTx (ShelleyLedgerEra Era)
 -> Tx TopTx (ShelleyLedgerEra Era))
-> Tx TopTx (ShelleyLedgerEra Era)
-> Tx TopTx (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$
                    Tx -> Tx TopTx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
tx
                      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx ConwayEra) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Set TxIn -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (TxIn -> TxIn) -> Set TxIn -> Set TxIn
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map TxIn -> TxIn
toLedgerTxIn (UTxO -> Set TxIn
forall era. UTxO era -> Set TxIn
UTxO.inputSet UTxO
utxoToDeposit)
                      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe Lovelace)
Lens' (TxBody TopTx ConwayEra) (StrictMaybe Lovelace)
totalCollateralTxBodyL ((StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictMaybe Lovelace -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Lovelace -> StrictMaybe Lovelace
forall a. a -> StrictMaybe a
SJust (UTxO -> Lovelace
forall era. UTxO era -> Lovelace
UTxO.totalLovelace UTxO
utxoToDeposit)
                      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Withdrawals -> Identity Withdrawals)
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Withdrawals -> Identity Withdrawals)
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals -> Identity Withdrawals)
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Withdrawals -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map AccountAddress Lovelace -> Withdrawals
Withdrawals (AccountAddress -> Lovelace -> Map AccountAddress Lovelace
forall k a. k -> a -> Map k a
Map.singleton AccountAddress
rewardAccount Lovelace
0)
                      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Redeemers ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton (AsIx Word32 AccountAddress -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 AccountAddress -> ConwayPlutusPurpose f era
ConwayRewarding (AsIx Word32 AccountAddress -> ConwayPlutusPurpose AsIx ConwayEra)
-> AsIx Word32 AccountAddress -> ConwayPlutusPurpose AsIx ConwayEra
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 AccountAddress
forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data ConwayEra
redeemer, ExUnits
exUnits))
                      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Map ScriptHash (Script ConwayEra)
     -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Map ScriptHash (Script ConwayEra)
    -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (Script ConwayEra)))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
(Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ConwayEra) (Map ScriptHash (Script ConwayEra))
scriptTxWitsL ((Map ScriptHash (Script ConwayEra)
  -> Identity (Map ScriptHash (AlonzoScript ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Map ScriptHash (AlonzoScript ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptHash
-> AlonzoScript ConwayEra
-> Map ScriptHash (AlonzoScript ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton ScriptHash
scriptHash AlonzoScript ConwayEra
script

          let signedL2tx :: Tx
signedL2tx = Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
walletSk Tx
tx'
          HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
signedL2tx]

          NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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 ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
              Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
signedL2tx
                Value -> [Value] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (Value
v Value -> Getting (Endo [Value]) Value Value -> [Value]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshot" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"confirmed" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Value]) Value Value
forall t. AsValue t => IndexedTraversal' Int t Value
IndexedTraversal' Int Value Value
values)

-- | Compute the integrity hash of a transaction using a list of plutus languages.
recomputeIntegrityHash ::
  (AlonzoEraPParams ppera, AlonzoEraTxWits txera, AlonzoEraTxBody txera, EraTx txera) =>
  PParams ppera ->
  [Language] ->
  Ledger.Tx TopTx txera ->
  Ledger.Tx TopTx txera
recomputeIntegrityHash :: forall ppera txera.
(AlonzoEraPParams ppera, AlonzoEraTxWits txera,
 AlonzoEraTxBody txera, EraTx txera) =>
PParams ppera -> [Language] -> Tx TopTx txera -> Tx TopTx txera
recomputeIntegrityHash PParams ppera
pp [Language]
languages Tx TopTx txera
tx =
  Tx TopTx txera
tx Tx TopTx txera
-> (Tx TopTx txera -> Tx TopTx txera) -> Tx TopTx txera
forall a b. a -> (a -> b) -> b
& (TxBody TopTx txera -> Identity (TxBody TopTx txera))
-> Tx TopTx txera -> Identity (Tx TopTx txera)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l txera) (TxBody l txera)
bodyTxL ((TxBody TopTx txera -> Identity (TxBody TopTx txera))
 -> Tx TopTx txera -> Identity (Tx TopTx txera))
-> ((StrictMaybe ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody TopTx txera -> Identity (TxBody TopTx txera))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> Tx TopTx txera
-> Identity (Tx TopTx txera)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody TopTx txera -> Identity (TxBody TopTx txera)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
forall (l :: TxLevel).
Lens' (TxBody l txera) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> Tx TopTx txera -> Identity (Tx TopTx txera))
-> StrictMaybe ScriptIntegrityHash
-> Tx TopTx txera
-> Tx TopTx txera
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe ScriptIntegrityHash
integrityHash
 where
  langViews :: Set LangDepView
langViews = [LangDepView] -> Set LangDepView
forall a. Ord a => [a] -> Set a
Set.fromList ([LangDepView] -> Set LangDepView)
-> [LangDepView] -> Set LangDepView
forall a b. (a -> b) -> a -> b
$ PParams ppera -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams ppera
pp (Language -> LangDepView) -> [Language] -> [LangDepView]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Language]
languages
  redeemers :: Redeemers txera
redeemers = Tx TopTx txera
tx Tx TopTx txera
-> Getting (Redeemers txera) (Tx TopTx txera) (Redeemers txera)
-> Redeemers txera
forall s a. s -> Getting a s a -> a
^. (TxWits txera -> Const (Redeemers txera) (TxWits txera))
-> Tx TopTx txera -> Const (Redeemers txera) (Tx TopTx txera)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l txera) (TxWits txera)
witsTxL ((TxWits txera -> Const (Redeemers txera) (TxWits txera))
 -> Tx TopTx txera -> Const (Redeemers txera) (Tx TopTx txera))
-> ((Redeemers txera -> Const (Redeemers txera) (Redeemers txera))
    -> TxWits txera -> Const (Redeemers txera) (TxWits txera))
-> Getting (Redeemers txera) (Tx TopTx txera) (Redeemers txera)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers txera -> Const (Redeemers txera) (Redeemers txera))
-> TxWits txera -> Const (Redeemers txera) (TxWits txera)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits txera) (Redeemers txera)
rdmrsTxWitsL
  txDats :: TxDats txera
txDats = Tx TopTx txera
tx Tx TopTx txera
-> Getting (TxDats txera) (Tx TopTx txera) (TxDats txera)
-> TxDats txera
forall s a. s -> Getting a s a -> a
^. (TxWits txera -> Const (TxDats txera) (TxWits txera))
-> Tx TopTx txera -> Const (TxDats txera) (Tx TopTx txera)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l txera) (TxWits txera)
witsTxL ((TxWits txera -> Const (TxDats txera) (TxWits txera))
 -> Tx TopTx txera -> Const (TxDats txera) (Tx TopTx txera))
-> ((TxDats txera -> Const (TxDats txera) (TxDats txera))
    -> TxWits txera -> Const (TxDats txera) (TxWits txera))
-> Getting (TxDats txera) (Tx TopTx txera) (TxDats txera)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats txera -> Const (TxDats txera) (TxDats txera))
-> TxWits txera -> Const (TxDats txera) (TxWits txera)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits txera) (TxDats txera)
datsTxWitsL
  integrityHash :: StrictMaybe ScriptIntegrityHash
integrityHash =
    if Map (PlutusPurpose AsIx txera) (Data txera, ExUnits) -> Bool
forall a. Map (PlutusPurpose AsIx txera) a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Redeemers txera
redeemers Redeemers txera
-> Getting
     (Map (PlutusPurpose AsIx txera) (Data txera, ExUnits))
     (Redeemers txera)
     (Map (PlutusPurpose AsIx txera) (Data txera, ExUnits))
-> Map (PlutusPurpose AsIx txera) (Data txera, ExUnits)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (PlutusPurpose AsIx txera) (Data txera, ExUnits))
  (Redeemers txera)
  (Map (PlutusPurpose AsIx txera) (Data txera, ExUnits))
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers txera)
  (Map (PlutusPurpose AsIx txera) (Data txera, ExUnits))
unRedeemersL) Bool -> Bool -> Bool
&& Set LangDepView -> Bool
forall a. Set a -> Bool
Set.null Set LangDepView
langViews Bool -> Bool -> Bool
&& Map DataHash (Data txera) -> Bool
forall a. Map DataHash a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TxDats txera
txDats TxDats txera
-> Getting
     (Map DataHash (Data txera))
     (TxDats txera)
     (Map DataHash (Data txera))
-> Map DataHash (Data txera)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map DataHash (Data txera))
  (TxDats txera)
  (Map DataHash (Data txera))
forall era. Era era => Lens' (TxDats era) (Map DataHash (Data era))
Lens' (TxDats txera) (Map DataHash (Data txera))
unTxDatsL)
      then StrictMaybe ScriptIntegrityHash
forall a. StrictMaybe a
SNothing
      else ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
SJust (ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash)
-> (ScriptIntegrity txera -> ScriptIntegrityHash)
-> ScriptIntegrity txera
-> StrictMaybe ScriptIntegrityHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptIntegrity txera -> ScriptIntegrityHash
forall era. Era era => ScriptIntegrity era -> ScriptIntegrityHash
hashScriptIntegrity (ScriptIntegrity txera -> StrictMaybe ScriptIntegrityHash)
-> ScriptIntegrity txera -> StrictMaybe ScriptIntegrityHash
forall a b. (a -> b) -> a -> b
$ Redeemers txera
-> TxDats txera -> Set LangDepView -> ScriptIntegrity txera
forall era.
Redeemers era
-> TxDats era -> Set LangDepView -> ScriptIntegrity era
ScriptIntegrity Redeemers txera
redeemers TxDats txera
txDats Set LangDepView
langViews

canDepositScriptBlueprint ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  IO ()
canDepositScriptBlueprint :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canDepositScriptBlueprint 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
20_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
    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
    let hydraNodeId :: Int
hydraNodeId = Int
1
    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
hydraNodeId 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])
      (Value
clientPayload, Tx
blueprint) <- Lovelace -> IO (Value, Tx)
prepareScriptPayload Lovelace
7_000_000

      Tx
commitTx <-
        (JsonResponse Tx -> Tx) -> IO (JsonResponse Tx) -> IO Tx
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonResponse Tx -> Tx
JsonResponse Tx -> HttpResponseBody (JsonResponse Tx)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody (IO (JsonResponse Tx) -> IO Tx) -> IO (JsonResponse Tx) -> IO Tx
forall a b. (a -> b) -> a -> b
$
          HttpConfig -> Req (JsonResponse Tx) -> IO (JsonResponse Tx)
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req (JsonResponse Tx) -> IO (JsonResponse Tx))
-> Req (JsonResponse Tx) -> IO (JsonResponse Tx)
forall a b. (a -> b) -> a -> b
$
            POST
-> Url 'Http
-> ReqBodyJson Value
-> Proxy (JsonResponse Tx)
-> Option 'Http
-> Req (JsonResponse Tx)
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST (Text -> Url 'Http
http Text
"127.0.0.1" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"commit") (Value -> ReqBodyJson Value
forall a. a -> ReqBodyJson a
ReqBodyJson Value
clientPayload) (Proxy (JsonResponse Tx)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse Tx)) (HydraClient -> Option 'Http
forall (scheme :: Scheme). HydraClient -> Option scheme
hydraApiPort HydraClient
n1)
      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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
commitTx

      -- The deposited UTxO in the head is keyed by the blueprint tx's outputs.
      let expectedDeposit :: UTxO
expectedDeposit = TxId -> [TxOut CtxTx Era] -> UTxO
constructDepositUTxO (TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
blueprint)) (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
blueprint)
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
commitTx)]
      HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO (Timing -> NominalDiffTime
depositTimeout Timing
timing) HydraClient
n1 UTxO
expectedDeposit
 where
  prepareScriptPayload :: Lovelace -> IO (Value, Tx)
prepareScriptPayload Lovelace
lovelaceAmt = do
    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
    let scriptAddress :: AddressInEra Era
scriptAddress = NetworkId -> PlutusScript -> AddressInEra Era
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript
dummyValidatorScript
    let datumHash :: TxOutDatum ctx
        datumHash :: forall ctx. TxOutDatum ctx
datumHash = () -> TxOutDatum ctx Era
forall era a ctx.
(ToScriptData a, IsAlonzoBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumHash ()
    (TxIn
scriptIn, TxOut CtxUTxO Era
scriptOut) <- NetworkId
-> ChainBackendOptions
-> AddressInEra Era
-> TxOutDatum CtxTx Era
-> Value
-> IO (TxIn, TxOut CtxUTxO Era)
createOutputAtAddress NetworkId
networkId ChainBackendOptions
opts AddressInEra Era
scriptAddress TxOutDatum CtxTx Era
forall ctx. TxOutDatum ctx
datumHash (Lovelace -> Value
lovelaceToValue Lovelace
lovelaceAmt)
    let scriptUTxO :: UTxO
scriptUTxO = TxIn -> TxOut CtxUTxO Era -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
scriptIn TxOut CtxUTxO Era
scriptOut
    let scriptWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
scriptWitness =
          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
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
PlutusScript lang
-> ScriptDatum ctx -> ScriptRedeemer -> ScriptWitness ctx era
mkScriptWitness PlutusScript
dummyValidatorScript (() -> ScriptDatum WitCtxTxIn
forall a. ToScriptData a => a -> ScriptDatum WitCtxTxIn
mkScriptDatum ()) (() -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData ())
    let blueprint :: Tx
blueprint =
          HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
            TxBodyContent BuildTx
defaultTxBodyContent
              TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(TxIn
scriptIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
scriptWitness)]
              TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxOut CtxTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxOut CtxTx era
-> TxBodyContent build era -> TxBodyContent build era
addTxOut (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO Era
scriptOut)
    (Value, Tx) -> IO (Value, Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( [Pair] -> Value
Aeson.object [Key
"blueprintTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
blueprint, Key
"utxo" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
scriptUTxO]
      , Tx
blueprint
      )

persistenceCanLoadWithNothingCommitted ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  IO ()
persistenceCanLoadWithNothingCommitted :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
persistenceCanLoadWithNothingCommitted 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
20_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
    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
    let hydraNodeId :: Int
hydraNodeId = Int
1
    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
    HeadId
headId <- Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO HeadId)
-> IO HeadId
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
hydraNodeId Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO HeadId) -> IO HeadId)
-> (HydraClient -> IO HeadId) -> IO HeadId
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" []
      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])
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withUnsyncedSoloHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
      HeadId
headId' <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 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])
      HeadId
headId' HeadId -> HeadId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` HeadId
headId

      -- NOTE: Deliberately sampled once rather than via 'waitForSnapshotUTxO'.
      -- This asserts a steady state (nothing was committed), and an empty
      -- snapshot is also what a node that has not finished loading reports, so
      -- polling for it would succeed immediately and assert nothing.
      HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n1 IO UTxO -> UTxO -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxO
forall a. Monoid a => a
mempty

-- | Initialize open and close a head on a real network and ensure contestation
-- period longer than the time horizon is possible. For this it is enough that
-- we can close a head and not wait for the deadline.
canCloseWithLongContestationPeriod ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  IO ()
canCloseWithLongContestationPeriod :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canCloseWithLongContestationPeriod Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Alice Lovelace
100_000_000
  -- Start hydra-node on chain tip
  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
  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 oneWeek :: ContestationPeriod
oneWeek = ContestationPeriod
60 ContestationPeriod -> ContestationPeriod -> ContestationPeriod
forall a. Num a => a -> a -> a
* ContestationPeriod
60 ContestationPeriod -> ContestationPeriod -> ContestationPeriod
forall a. Num a => a -> a -> a
* ContestationPeriod
24 ContestationPeriod -> ContestationPeriod -> ContestationPeriod
forall a. Num a => a -> a -> a
* ContestationPeriod
7
      Timing{$sel:depositPeriod:Timing :: Timing -> DepositPeriod
depositPeriod = DepositPeriod
defaultDepositPeriod} = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
chainConfigFor' Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [] ContestationPeriod
oneWeek DepositPeriod
defaultDepositPeriod DepositPeriod
defaultDepositPeriod
      IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CardanoChainConfig -> CardanoChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\CardanoChainConfig
config -> CardanoChainConfig
config{startChainFrom = Just tip})
  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
    -- Initialize & open head
    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])
    -- Close head
    HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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 ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"HeadIsClosed"
  Actor -> IO ()
traceRemainingFunds Actor
Alice
 where
  traceRemainingFunds :: Actor -> IO ()
traceRemainingFunds Actor
actor = do
    (VerificationKey PaymentKey
actorVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
actor
    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
$ QueryPoint -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> VerificationKey PaymentKey -> m UTxO
queryUTxOFor QueryPoint
QueryTip VerificationKey PaymentKey
actorVk
    Tracer IO EndToEndLog -> EndToEndLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO EndToEndLog
tracer RemainingFunds{$sel:actor:ClusterOptions :: String
actor = Actor -> String
actorName Actor
actor, UTxO
$sel:utxo:ClusterOptions :: UTxO
utxo :: UTxO
utxo}

canSubmitTransactionThroughAPI ::
  Tracer IO EndToEndLog ->
  FilePath ->
  ChainBackendOptions ->
  [TxId] ->
  IO ()
canSubmitTransactionThroughAPI :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canSubmitTransactionThroughAPI 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
25_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
    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
    let hydraNodeId :: Int
hydraNodeId = Int
1
    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
hydraNodeId Secret (SigningKey HydraKey)
aliceSk [] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
      -- let's prepare a _user_ transaction from Bob to Carol
      (VerificationKey PaymentKey
cardanoBobVk, Secret (SigningKey PaymentKey)
cardanoBobSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Bob
      (VerificationKey PaymentKey
cardanoCarolVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Carol
      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
      -- create output for Bob to be sent to carol
      UTxO
bobUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
cardanoBobVk (Lovelace -> Value
lovelaceToValue Lovelace
5_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)
      let carolsAddress :: AddressInEra Era
carolsAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
cardanoCarolVk
          bobsAddress :: AddressInEra Era
bobsAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
cardanoBobVk
          carolsOutput :: TxOut CtxTx Era
carolsOutput =
            AddressInEra Era
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript Era -> TxOut ctx
TxOut
              AddressInEra Era
carolsAddress
              (Lovelace -> Value
lovelaceToValue (Lovelace -> Value) -> Lovelace -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Lovelace
Coin Integer
2_000_000)
              TxOutDatum CtxTx Era
forall ctx. TxOutDatum ctx
TxOutDatumNone
              ReferenceScript Era
ReferenceScriptNone
      -- prepare fully balanced tx body
      ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m (Either (TxBodyErrorAutoBalance Era) Tx))
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
forall a.
ChainBackendOptions
-> (forall (m :: * -> *).
    (ChainBackend m, MonadIO m, MonadThrow m, MonadCatch m) =>
    m a)
-> IO a
runBackend ChainBackendOptions
opts (AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
forall (m :: * -> *).
(ChainBackend m, MonadIO m) =>
AddressInEra Era
-> UTxO
-> [TxIn]
-> [TxOut CtxTx Era]
-> m (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction AddressInEra Era
bobsAddress UTxO
bobUTxO ((TxIn, TxOut CtxUTxO Era) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, TxOut CtxUTxO Era) -> TxIn)
-> [(TxIn, TxOut CtxUTxO Era)] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
bobUTxO) [TxOut CtxTx Era
carolsOutput]) IO (Either (TxBodyErrorAutoBalance Era) Tx)
-> (Either (TxBodyErrorAutoBalance Era) Tx -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left TxBodyErrorAutoBalance Era
e -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ TxBodyErrorAutoBalance Era -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyErrorAutoBalance Era
e
        Right Tx
tx -> do
          let unsignedTx :: Tx
unsignedTx = [KeyWitness Era] -> TxBody Era -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] (TxBody Era -> Tx) -> TxBody Era -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx
          let unsignedRequest :: Value
unsignedRequest = Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
unsignedTx
          HydraClient -> Value -> IO (JsonResponse TransactionSubmitted)
forall (m :: * -> *) tx.
(MonadIO m, ToJSON tx) =>
HydraClient -> tx -> m (JsonResponse TransactionSubmitted)
sendRequest HydraClient
n1 Value
unsignedRequest
            IO (JsonResponse TransactionSubmitted)
-> Selector HttpException -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` Int -> Maybe ByteString -> Selector HttpException
expectErrorStatus Int
400 (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"MissingVKeyWitnessesUTXOW")

          let signedTx :: Tx
signedTx = Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
cardanoBobSk Tx
unsignedTx
          let signedRequest :: Value
signedRequest = Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
signedTx
          (HydraClient -> Value -> IO (JsonResponse TransactionSubmitted)
forall (m :: * -> *) tx.
(MonadIO m, ToJSON tx) =>
HydraClient -> tx -> m (JsonResponse TransactionSubmitted)
sendRequest HydraClient
n1 Value
signedRequest IO (JsonResponse TransactionSubmitted)
-> (JsonResponse TransactionSubmitted -> TransactionSubmitted)
-> IO TransactionSubmitted
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> JsonResponse TransactionSubmitted -> TransactionSubmitted
JsonResponse TransactionSubmitted
-> HttpResponseBody (JsonResponse TransactionSubmitted)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody)
            IO TransactionSubmitted -> TransactionSubmitted -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` TransactionSubmitted
TransactionSubmitted
 where
  sendRequest :: (MonadIO m, ToJSON tx) => HydraClient -> tx -> m (JsonResponse TransactionSubmitted)
  sendRequest :: forall (m :: * -> *) tx.
(MonadIO m, ToJSON tx) =>
HydraClient -> tx -> m (JsonResponse TransactionSubmitted)
sendRequest HydraClient
client tx
tx =
    HttpConfig
-> Req (JsonResponse TransactionSubmitted)
-> m (JsonResponse TransactionSubmitted)
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req (JsonResponse TransactionSubmitted)
 -> m (JsonResponse TransactionSubmitted))
-> Req (JsonResponse TransactionSubmitted)
-> m (JsonResponse TransactionSubmitted)
forall a b. (a -> b) -> a -> b
$
      POST
-> Url 'Http
-> ReqBodyJson tx
-> Proxy (JsonResponse TransactionSubmitted)
-> Option 'Http
-> Req (JsonResponse TransactionSubmitted)
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req
        POST
POST
        (Text -> Url 'Http
http Text
"127.0.0.1" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"cardano-transaction")
        (tx -> ReqBodyJson tx
forall a. a -> ReqBodyJson a
ReqBodyJson tx
tx)
        (Proxy (JsonResponse TransactionSubmitted)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse TransactionSubmitted))
        (HydraClient -> Option 'Http
forall (scheme :: Scheme). HydraClient -> Option scheme
hydraApiPort HydraClient
client)

-- | Three hydra nodes open a head and we assert that none of them sees errors.
-- This was particularly misleading when everyone tries to post the collect
-- transaction concurrently.
threeNodesNoErrorsOnOpen :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
threeNodesNoErrorsOnOpen :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
threeNodesNoErrorsOnOpen Tracer IO EndToEndLog
tracer String
tmpDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  (VerificationKey PaymentKey
aliceCardanoVk, SigningKey PaymentKey
aliceCardanoSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
  (VerificationKey PaymentKey
bobCardanoVk, SigningKey PaymentKey
bobCardanoSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
  (VerificationKey PaymentKey
carolCardanoVk, SigningKey PaymentKey
carolCardanoSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair

  let cardanoKeys :: [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
cardanoKeys =
        [ (VerificationKey PaymentKey
aliceCardanoVk, SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
aliceCardanoSk)
        , (VerificationKey PaymentKey
bobCardanoVk, SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
bobCardanoSk)
        , (VerificationKey PaymentKey
carolCardanoVk, SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
carolCardanoSk)
        ]
      hydraKeys :: [Secret (SigningKey HydraKey)]
hydraKeys = [Secret (SigningKey HydraKey)
aliceSk, Secret (SigningKey HydraKey)
bobSk, Secret (SigningKey HydraKey)
carolSk]

  let contestationPeriod :: ContestationPeriod
contestationPeriod = ContestationPeriod
2
  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
  let nodeSocket' :: SocketPath
nodeSocket' =
        case ChainBackendOptions
opts of
          Direct DirectOptions{SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket} -> SocketPath
nodeSocket
          Blockfrost BlockfrostOptions
_ -> Text -> SocketPath
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Unexpected Blockfrost options"
  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 depositPeriod :: DepositPeriod
depositPeriod = NominalDiffTime -> DepositPeriod
truncatedDepositPeriod (NominalDiffTime -> DepositPeriod)
-> NominalDiffTime -> DepositPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime
  let timing :: Timing
timing = Timing{NominalDiffTime
$sel:blockTime:Timing :: NominalDiffTime
blockTime :: NominalDiffTime
blockTime, ContestationPeriod
$sel:contestationPeriod:Timing :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Timing :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, $sel:depositActivation:Timing :: DepositPeriod
depositActivation = DepositPeriod
depositPeriod}
  Tracer IO HydraNodeLog
-> Timing
-> String
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> [Secret (SigningKey HydraKey)]
-> [TxId]
-> (NonEmpty HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> Timing
-> String
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> [Secret (SigningKey HydraKey)]
-> [TxId]
-> (NonEmpty HydraClient -> IO a)
-> IO a
withHydraCluster Tracer IO HydraNodeLog
hydraTracer Timing
timing String
tmpDir SocketPath
nodeSocket' Int
1 [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
cardanoKeys [Secret (SigningKey HydraKey)]
hydraKeys [TxId]
hydraScriptsTxId ((NonEmpty HydraClient -> IO ()) -> IO ())
-> (NonEmpty HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty HydraClient
clients -> do
    let leader :: HydraClient
leader = NonEmpty HydraClient -> HydraClient
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty HydraClient
clients
    Tracer IO HydraNodeLog
-> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
20 NonEmpty HydraClient
clients

    -- Funds to be used as fuel by Hydra protocol transactions
    ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
    ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk Lovelace
100_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)
    ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
carolCardanoVk Lovelace
100_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)

    HydraClient -> Value -> IO ()
send HydraClient
leader (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
    (HydraClient -> IO ()) -> NonEmpty HydraClient -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ HydraClient -> IO ()
shouldNotReceivePostTxError NonEmpty HydraClient
clients
 where
  --  Fail if a 'PostTxOnChainFailed' message is received.
  shouldNotReceivePostTxError :: HydraClient -> IO ()
shouldNotReceivePostTxError client :: HydraClient
client@HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} = do
    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
    Either (Maybe Value) ()
err <- NominalDiffTime
-> HydraClient
-> (Value -> Maybe (Either (Maybe Value) ()))
-> IO (Either (Maybe Value) ())
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
client ((Value -> Maybe (Either (Maybe Value) ()))
 -> IO (Either (Maybe Value) ()))
-> (Value -> Maybe (Either (Maybe Value) ()))
-> IO (Either (Maybe Value) ())
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
      case 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" of
        Just Value
"PostTxOnChainFailed" -> Either (Maybe Value) () -> Maybe (Either (Maybe Value) ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe Value) () -> Maybe (Either (Maybe Value) ()))
-> Either (Maybe Value) () -> Maybe (Either (Maybe Value) ())
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Either (Maybe Value) ()
forall a b. a -> Either a b
Left (Maybe Value -> Either (Maybe Value) ())
-> Maybe Value -> Either (Maybe Value) ()
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
"postTxError"
        Just Value
"HeadIsOpen" -> Either (Maybe Value) () -> Maybe (Either (Maybe Value) ())
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Maybe Value) () -> Maybe (Either (Maybe Value) ()))
-> Either (Maybe Value) () -> Maybe (Either (Maybe Value) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (Maybe Value) ()
forall a b. b -> Either a b
Right ()
        Maybe Value
_ -> Maybe (Either (Maybe Value) ())
forall a. Maybe a
Nothing
    case Either (Maybe Value) ()
err of
      Left Maybe Value
receivedError ->
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"node " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" should not receive error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Value -> String
forall b a. (Show a, IsString b) => a -> b
show Maybe Value
receivedError
      Right ()
_headIsOpen ->
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Hydra nodes ABC run on ABC cluster and connect to each other.
-- Hydra nodes BC shut down.
-- Hydra nodes BC run on BC cluster and connect to each other.
-- Hydra nodes BC shut down.
-- Hydra nodes BC run and connect ABC cluster again.
nodeCanSupportMultipleEtcdClusters :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
nodeCanSupportMultipleEtcdClusters :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
nodeCanSupportMultipleEtcdClusters Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  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
  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
  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 [Actor
Bob, Actor
Carol] 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
  ChainConfig
bobChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Carol] 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
  ChainConfig
carolChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Carol String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Bob] 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

  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2, Int
3]
  let subClusterPorts :: Map Int HydraNodePorts
subClusterPorts = Map Int HydraNodePorts -> Set Int -> Map Int HydraNodePorts
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map Int HydraNodePorts
nodePorts ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int
2, Int
3])

  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk, VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
carolChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        Tracer IO HydraNodeLog
-> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
30 (NonEmpty HydraClient -> IO ()) -> NonEmpty HydraClient -> IO ()
forall a b. (a -> b) -> a -> b
$ HydraClient
n1 HydraClient -> [HydraClient] -> NonEmpty HydraClient
forall a. a -> [a] -> NonEmpty a
:| [HydraClient
n2, HydraClient
n3]

    ChainConfig
bobChainConfig' <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Carol] 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
    ChainConfig
carolChainConfig' <-
      HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Carol String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Bob] 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

    Tracer IO HydraNodeLog
-> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesDisconnected Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
60 (NonEmpty HydraClient -> IO ()) -> NonEmpty HydraClient -> IO ()
forall a b. (a -> b) -> a -> b
$ HydraClient
n1 HydraClient -> [HydraClient] -> NonEmpty HydraClient
forall a. a -> [a] -> NonEmpty a
:| []

    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig' String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
subClusterPorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
carolChainConfig' String
workDir Int
3 Secret (SigningKey HydraKey)
carolSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
subClusterPorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        Tracer IO HydraNodeLog
-> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
30 (NonEmpty HydraClient -> IO ()) -> NonEmpty HydraClient -> IO ()
forall a b. (a -> b) -> a -> b
$ HydraClient
n2 HydraClient -> [HydraClient] -> NonEmpty HydraClient
forall a. a -> [a] -> NonEmpty a
:| [HydraClient
n3]

    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
carolChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        Tracer IO HydraNodeLog
-> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
30 (NonEmpty HydraClient -> IO ()) -> NonEmpty HydraClient -> IO ()
forall a b. (a -> b) -> a -> b
$ HydraClient
n1 HydraClient -> [HydraClient] -> NonEmpty HydraClient
forall a. a -> [a] -> NonEmpty a
:| [HydraClient
n2, HydraClient
n3]

-- | Two hydra node setup where Alice is wrongly configured to use Carol's
-- cardano keys instead of Bob's which will prevent him to be notified the
-- `HeadIsInitializing` but he should still receive some notification.
initWithWrongKeys :: FilePath -> Tracer IO EndToEndLog -> ChainBackendOptions -> [TxId] -> IO ()
initWithWrongKeys :: String
-> Tracer IO EndToEndLog -> ChainBackendOptions -> [TxId] -> IO ()
initWithWrongKeys String
workDir Tracer IO EndToEndLog
tracer ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice
  (VerificationKey PaymentKey
carolCardanoVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Carol

  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
  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 [Actor
Carol] Timing
timing
  ChainConfig
bobChainConfig <- HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] Timing
timing

  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
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
3, Int
4]
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
4 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
      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.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 [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, Party
bob])

      let expectedParticipants :: [OnChainId]
expectedParticipants =
            VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId
              (VerificationKey PaymentKey -> OnChainId)
-> [VerificationKey PaymentKey] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VerificationKey PaymentKey
aliceCardanoVk, VerificationKey PaymentKey
carolCardanoVk]

      -- We want the client to observe headId being opened without bob (node 2)
      -- being part of it
      [OnChainId]
participants <- NominalDiffTime
-> HydraClient -> (Value -> Maybe [OnChainId]) -> IO [OnChainId]
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
n2 ((Value -> Maybe [OnChainId]) -> IO [OnChainId])
-> (Value -> Maybe [OnChainId]) -> IO [OnChainId]
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 (Text -> Value
Aeson.String Text
"IgnoredHeadInitializing")
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
        Value
v Value
-> Getting (First [OnChainId]) Value [OnChainId]
-> Maybe [OnChainId]
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
"participants" ((Value -> Const (First [OnChainId]) Value)
 -> Value -> Const (First [OnChainId]) Value)
-> Getting (First [OnChainId]) Value [OnChainId]
-> Getting (First [OnChainId]) Value [OnChainId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First [OnChainId]) Value [OnChainId]
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value [OnChainId] [OnChainId]
_JSON

      [OnChainId]
participants [OnChainId] -> [OnChainId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldMatchList` [OnChainId]
expectedParticipants

-- | Scenario for a deposit-period mismatch between peers: alice initializes a
-- head while bob is configured with a different --deposit-period, so bob's
-- node must ignore the head entirely (issue #2664).
initWithDifferentDepositPeriod :: FilePath -> Tracer IO EndToEndLog -> ChainBackendOptions -> [TxId] -> IO ()
initWithDifferentDepositPeriod :: String
-> Tracer IO EndToEndLog -> ChainBackendOptions -> [TxId] -> IO ()
initWithDifferentDepositPeriod String
workDir Tracer IO EndToEndLog
tracer ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice

  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{ContestationPeriod
$sel:contestationPeriod:Timing :: Timing -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, DepositPeriod
$sel:depositPeriod:Timing :: Timing -> DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod} = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
  ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
chainConfigFor' Actor
Alice String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod DepositPeriod
depositPeriod DepositPeriod
depositPeriod
  -- NOTE: here we deliberately configure a different deposit period for Bob
  ChainConfig
bobChainConfig <- HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositPeriod
-> DepositPeriod
-> IO ChainConfig
chainConfigFor' Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod (DepositPeriod
2 DepositPeriod -> DepositPeriod -> DepositPeriod
forall a. Num a => a -> a -> a
* DepositPeriod
depositPeriod) (DepositPeriod
2 DepositPeriod -> DepositPeriod -> DepositPeriod
forall a. Num a => a -> a -> a
* DepositPeriod
depositPeriod)

  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
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
3, Int
4]
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
4 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
      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.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 [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, Party
bob])

      -- Bob's node must ignore the head due to the deposit-period mismatch
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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
n2 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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 (Text -> Value
Aeson.String Text
"IgnoredHeadInitializing")
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)

startWithWrongPeers :: FilePath -> Tracer IO EndToEndLog -> ChainBackendOptions -> [TxId] -> IO ()
startWithWrongPeers :: String
-> Tracer IO EndToEndLog -> ChainBackendOptions -> [TxId] -> IO ()
startWithWrongPeers String
workDir Tracer IO EndToEndLog
tracer ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice

  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
  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 [Actor
Carol] Timing
timing
  ChainConfig
bobChainConfig <- HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] Timing
timing

  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
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
3, Int
4]
  let bobAlonePorts :: Map Int HydraNodePorts
bobAlonePorts = Map Int HydraNodePorts -> Set Int -> Map Int HydraNodePorts
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map Int HydraNodePorts
nodePorts (Int -> Set Int
forall a. a -> Set a
Set.singleton Int
4)
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    -- NOTE: here we deliberately use the wrong peer list for Bob
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
4 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
bobAlonePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
_ -> do
      ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)

      (Text
clusterPeers, Text
configuredPeers) <- NominalDiffTime
-> HydraClient -> (Value -> Maybe (Text, Text)) -> IO (Text, Text)
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe (Text, Text)) -> IO (Text, Text))
-> (Value -> Maybe (Text, Text)) -> IO (Text, Text)
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 (Text -> Value
Aeson.String Text
"NetworkClusterIDMismatch")
        Text
clusterPeers <- Value
v Value -> Getting (First Text) Value Text -> Maybe Text
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
"clusterPeers" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
        Text
configuredPeers <- Value
v Value -> Getting (First Text) Value Text -> Maybe Text
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
"misconfiguredPeers" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
        (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
clusterPeers, Text
configuredPeers)

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
clusterPeers Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
configuredPeers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Expected clusterPeers and configuredPeers to be different"
      let alicePort :: PortNumber
alicePort = HydraNodePorts -> PortNumber
listenPort (Map Int HydraNodePorts
nodePorts Map Int HydraNodePorts -> Int -> HydraNodePorts
forall k a. Ord k => Map k a -> k -> a
Map.! Int
3)
          bobPort :: PortNumber
bobPort = HydraNodePorts -> PortNumber
listenPort (Map Int HydraNodePorts
nodePorts Map Int HydraNodePorts -> Int -> HydraNodePorts
forall k a. Ord k => Map k a -> k -> a
Map.! Int
4)
          peerEntry :: Network.PortNumber -> Text
          peerEntry :: PortNumber -> Text
peerEntry PortNumber
p = Text
"0.0.0.0:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Text
forall b a. (Show a, IsString b) => a -> b
show PortNumber
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=http://0.0.0.0:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Text
forall b a. (Show a, IsString b) => a -> b
show PortNumber
p
      Text
clusterPeers Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` PortNumber -> Text
peerEntry PortNumber
alicePort Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Text
peerEntry PortNumber
bobPort
      Text
configuredPeers Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` PortNumber -> Text
peerEntry PortNumber
bobPort

-- | Open a a two participant head, deposit funds to it and distribute them on fanout.
canDepositConcurrently :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canDepositConcurrently :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canDepositConcurrently 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
$
    (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
Bob) (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
      Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Bob 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
      -- 2 concurrent deposits = 2 sequential increments on-chain
      let timing :: Timing
timing = Int -> NominalDiffTime -> Timing
mkTestTiming' Int
2 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 [Actor
Bob] 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
      ChainConfig
bobChainConfig <-
        HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] 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
      Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2]
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> 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.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] ((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, Party
bob])

          (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
          -- Seed both UTxOs before drafting deposits so L1 confirmations don't
          -- eat into the deposit deadline window.
          UTxO
commitUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
5_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)
          UTxO
commitUTxO2 <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
5_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)

          -- Draft and submit both deposits concurrently.
          (Tx
tx, Tx
tx2) <-
            IO Tx -> IO Tx -> IO (Tx, Tx)
forall a b. IO a -> IO b -> IO (a, b)
concurrently
              ( do
                  Response Tx
resp <-
                    String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
                      IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO
commitUTxO IO Request -> (Request -> IO (Response Tx)) -> IO (Response Tx)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response Tx)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
                  let signed :: Tx
signed = SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk (Response Tx -> Tx
forall a. Response a -> a
getResponseBody Response Tx
resp :: Tx)
                  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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
signed
                  Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
signed
              )
              ( do
                  Response Tx
resp <-
                    String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
                      IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO
commitUTxO2 IO Request -> (Request -> IO (Response Tx)) -> IO (Response Tx)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response Tx)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
                  let signed :: Tx
signed = SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk (Response Tx -> Tx
forall a. Response a -> a
getResponseBody Response Tx
resp :: Tx)
                  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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
signed
                  Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
signed
              )

          -- Wait for both CommitFinalized events in any order, then assert all
          -- expected tx ids were seen (benchmark pattern).
          let expectedTxIds :: Set TxId
expectedTxIds = [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList [TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx), TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx2)]
          Set TxId
seenTxIds <- ([TxId] -> Set TxId) -> IO [TxId] -> IO (Set TxId)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TxId] -> Set TxId
forall a. Ord a => [a] -> Set a
Set.fromList (IO [TxId] -> IO (Set TxId)) -> IO [TxId] -> IO (Set TxId)
forall a b. (a -> b) -> a -> b
$
            Int -> IO TxId -> IO [TxId]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (IO TxId -> IO [TxId]) -> IO TxId -> IO [TxId]
forall a b. (a -> b) -> a -> b
$
              NominalDiffTime
-> [HydraClient] -> (Value -> Maybe TxId) -> IO TxId
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1, HydraClient
n2] ((Value -> Maybe TxId) -> IO TxId)
-> (Value -> Maybe TxId) -> IO TxId
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
"CommitFinalized"
                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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
                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
"depositTxId" Maybe Value -> (Value -> Maybe TxId) -> Maybe TxId
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 TxId) -> Value -> Maybe TxId
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser TxId
forall a. FromJSON a => Value -> Parser a
parseJSON
          Set TxId
seenTxIds Set TxId -> Set TxId -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Set TxId
expectedTxIds

          HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO (Timing -> NominalDiffTime
depositTimeout Timing
timing) HydraClient
n1 (UTxO
commitUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO2)

          HydraClient -> Value -> IO ()
send HydraClient
n2 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []
          UTCTime
deadline <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
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
n2 ((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
"HeadIsClosed"
            Value
v Value -> Getting (First UTCTime) Value UTCTime -> Maybe UTCTime
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
"contestationDeadline" ((Value -> Const (First UTCTime) Value)
 -> Value -> Const (First UTCTime) Value)
-> Getting (First UTCTime) Value UTCTime
-> Getting (First UTCTime) Value UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTCTime) Value UTCTime
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTCTime UTCTime
_JSON
          NominalDiffTime
remainingTime <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
remainingTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> [Pair] -> Value
output Text
"ReadyToFanout" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId]
          HydraClient -> Value -> IO ()
send HydraClient
n2 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Fanout" []
          NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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
n2 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
            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
"HeadIsFinalized"

          (UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> ValueType Tx)
-> IO (UTxOType Tx) -> IO (ValueType Tx)
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))
-> IO (UTxOType Tx)
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
walletVk))
            IO (ValueType Tx) -> ValueType Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO
commitUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO2)
 where
  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

rejectDeposit :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
rejectDeposit :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
rejectDeposit 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
    -- NOTE: Adapt periods to block times
    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 depositPeriod :: DepositPeriod
depositPeriod = NominalDiffTime -> DepositPeriod
truncatedDepositPeriod (NominalDiffTime -> DepositPeriod)
-> NominalDiffTime -> DepositPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
100 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime
    let timing :: Timing
timing = Timing{NominalDiffTime
$sel:blockTime:Timing :: NominalDiffTime
blockTime :: NominalDiffTime
blockTime, $sel:contestationPeriod:Timing :: ContestationPeriod
contestationPeriod = NominalDiffTime -> ContestationPeriod
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (NominalDiffTime -> ContestationPeriod)
-> NominalDiffTime -> ContestationPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime, DepositPeriod
$sel:depositPeriod:Timing :: DepositPeriod
depositPeriod :: DepositPeriod
depositPeriod, $sel:depositActivation:Timing :: DepositPeriod
depositActivation = DepositPeriod
depositPeriod}
    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 pparamsDecorator :: Value -> Value
pparamsDecorator = Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"utxoCostPerByte" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Scientific -> Value
Aeson.Number Scientific
4310)
    Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1]
    RunOptions
optionsWithUTxOCostPerByte <- HasCallStack =>
ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [] Map Int HydraNodePorts
nodePorts Value -> Value
pparamsDecorator
    Tracer IO HydraNodeLog
-> String -> Int -> RunOptions -> (HydraClient -> IO ()) -> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> String -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
withPreparedHydraNode Tracer IO HydraNodeLog
hydraTracer String
workDir Int
1 RunOptions
optionsWithUTxOCostPerByte ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
      IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => NominalDiffTime -> [HydraClient] -> IO ()
NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesSynced (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1]
      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
walletVk, 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
      UTxO
commitUTxO' <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
2_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)
      TxOut AddressInEra Era
_ Value
_ TxOutDatum Any
_ ReferenceScript Era
refScript <- Gen (TxOut Any) -> IO (TxOut Any)
forall a. Gen a -> IO a
generate Gen (TxOut Any)
forall ctx. Gen (TxOut ctx)
genTxOutWithReferenceScript
      TxOutDatum CtxUTxO
datum <- Gen (TxOutDatum CtxUTxO) -> IO (TxOutDatum CtxUTxO)
forall a. Gen a -> IO a
generate Gen (TxOutDatum CtxUTxO)
forall ctx. Gen (TxOutDatum ctx)
genDatum
      let UTxO
commitUTxO :: UTxO =
            [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall era. [(TxIn, TxOut CtxUTxO era)] -> UTxO era
UTxO.fromList ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall a b. (a -> b) -> a -> b
$
              (\(TxIn
i, TxOut AddressInEra Era
addr Value
_ TxOutDatum CtxUTxO
_ ReferenceScript Era
_) -> (TxIn
i, AddressInEra Era
-> Value
-> TxOutDatum CtxUTxO
-> ReferenceScript Era
-> TxOut CtxUTxO Era
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript Era -> TxOut ctx
TxOut AddressInEra Era
addr (Lovelace -> Value
lovelaceToValue Lovelace
0) TxOutDatum CtxUTxO
datum ReferenceScript Era
refScript))
                ((TxIn, TxOut CtxUTxO Era) -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
commitUTxO'
      Response (PostTxError Tx)
response <-
        String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
L.parseRequest (String
"POST " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
          IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON (UTxO
commitUTxO :: UTxO)
            IO Request
-> (Request -> IO (Response (PostTxError Tx)))
-> IO (Response (PostTxError Tx))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response (PostTxError Tx))
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON

      let expectedError :: PostTxError Tx
expectedError = Response (PostTxError Tx) -> PostTxError Tx
forall a. Response a -> a
getResponseBody Response (PostTxError Tx)
response :: PostTxError Tx

      PostTxError Tx
expectedError PostTxError Tx -> (PostTxError Tx -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
        DepositTooLow{Lovelace
minimumValue :: Lovelace
$sel:minimumValue:NoSeedInput :: forall tx. PostTxError tx -> Lovelace
minimumValue, Lovelace
providedValue :: Lovelace
$sel:providedValue:NoSeedInput :: forall tx. PostTxError tx -> Lovelace
providedValue} -> Lovelace
providedValue Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
< Lovelace
minimumValue
        PostTxError Tx
_ -> Bool
False
 where
  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

-- | Open a single participant head and deposit part of a UTxO, with the
-- remainder returned to a change address. This exercises the 'changeAddress'
-- balancing path in the deposit blueprint API.
canDepositPartially :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canDepositPartially :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canDepositPartially 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
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
      let seedAmount :: Lovelace
seedAmount = Lovelace
20_000_000
      let commitAmount :: Lovelace
commitAmount = Lovelace
10_000_000
      UTxO
commitUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
seedAmount) ((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)

      let changeAddress :: AddressInEra Era
changeAddress = forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress @Era NetworkId
networkId VerificationKey PaymentKey
walletVk
      let (TxIn
i, TxOut CtxUTxO Era
o') = [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
commitUTxO
      let o :: TxOut CtxUTxO Era
o = (Value -> Value) -> TxOut CtxUTxO Era -> TxOut CtxUTxO Era
forall era ctx.
IsMaryBasedEra era =>
(Value -> Value) -> TxOut ctx era -> TxOut ctx era
modifyTxOutValue (Value -> Value -> Value
forall a b. a -> b -> a
const (Value -> Value -> Value) -> Value -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Lovelace -> Value
lovelaceToValue Lovelace
commitAmount) TxOut CtxUTxO Era
o'
      let witness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
witness = 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
      let blueprint :: Tx
blueprint =
            HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
              TxBodyContent BuildTx
defaultTxBodyContent
                TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(TxIn
i, BuildTxWith BuildTx (Witness WitCtxTxIn)
witness)]
                TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxOut CtxTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxOut CtxTx era
-> TxBodyContent build era -> TxBodyContent build era
addTxOut (TxOut CtxUTxO Era -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO Era
o)
      let (CAPI.TxIn TxId
_ TxIx
index) = TxIn
i
      let depositedUTxO :: UTxO
depositedUTxO = TxIn -> TxOut CtxUTxO Era -> UTxO
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton (TxId -> TxIx -> TxIn
CAPI.TxIn (TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> TxBody Era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
blueprint) TxIx
index) TxOut CtxUTxO Era
o
      let clientPayload :: Value
clientPayload =
            [Pair] -> Value
Aeson.object
              [ Key
"blueprintTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
blueprint
              , Key
"utxo" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
commitUTxO
              , Key
"changeAddress" Key -> AddressInEra Era -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= AddressInEra Era
changeAddress
              ]

      JsonResponse Tx
res <-
        HttpConfig -> Req (JsonResponse Tx) -> IO (JsonResponse Tx)
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req (JsonResponse Tx) -> IO (JsonResponse Tx))
-> Req (JsonResponse Tx) -> IO (JsonResponse Tx)
forall a b. (a -> b) -> a -> b
$
          POST
-> Url 'Http
-> ReqBodyJson Value
-> Proxy (JsonResponse Tx)
-> Option 'Http
-> Req (JsonResponse Tx)
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST (Text -> Url 'Http
http Text
"127.0.0.1" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"commit") (Value -> ReqBodyJson Value
forall a. a -> ReqBodyJson a
ReqBodyJson Value
clientPayload) (Proxy (JsonResponse Tx)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse Tx)) (HydraClient -> Option 'Http
forall (scheme :: Scheme). HydraClient -> Option scheme
hydraApiPort HydraClient
n1)

      let tx :: Tx
tx = SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk (Tx -> Tx) -> Tx -> Tx
forall a b. (a -> b) -> a -> b
$ JsonResponse Tx -> HttpResponseBody (JsonResponse Tx)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody JsonResponse Tx
res
      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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx

      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx)]

      HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO (Timing -> NominalDiffTime
depositTimeout Timing
timing) HydraClient
n1 UTxO
depositedUTxO
      (UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Value) -> IO (UTxOType Tx) -> IO Value
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))
-> IO (UTxOType Tx)
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
walletVk))
        IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue (Lovelace
seedAmount Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
- Lovelace
commitAmount)

-- | Open a a single participant head, deposit and then recover it.
canRecoverDeposit :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canRecoverDeposit :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canRecoverDeposit 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
$
    (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
Bob) (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
      Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Bob Lovelace
30_000_000
      -- NOTE: Directly expire deposits
      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
      -- Use short periods so deposits expire quickly
      let timing :: Timing
timing = Timing{NominalDiffTime
$sel:blockTime:Timing :: NominalDiffTime
blockTime :: NominalDiffTime
blockTime, $sel:contestationPeriod:Timing :: ContestationPeriod
contestationPeriod = ContestationPeriod
1, $sel:depositPeriod:Timing :: DepositPeriod
depositPeriod = DepositPeriod
1, $sel:depositActivation:Timing :: DepositPeriod
depositActivation = DepositPeriod
1}
      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 [Actor
Bob] 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
      ChainConfig
bobChainConfig <-
        HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] 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
      Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2]
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        HeadId
headId <- Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO HeadId)
-> IO HeadId
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO HeadId) -> IO HeadId)
-> (HydraClient -> IO HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
          HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
          NominalDiffTime
-> [HydraClient] -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] ((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, Party
bob])
        -- stop the second node here

        -- Get some L1 funds
        (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
        let commitAmount :: Lovelace
commitAmount = Lovelace
5_000_000
        UTxO
commitUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
commitAmount) ((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)

        (UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Value) -> IO (UTxOType Tx) -> IO Value
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))
-> IO (UTxOType Tx)
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
walletVk))
          IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue Lovelace
commitAmount

        Tx
depositTransaction <-
          String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
            IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO
commitUTxO
              IO Request -> (Request -> IO (Response Tx)) -> IO (Response Tx)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response Tx)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
            IO (Response Tx) -> (Response Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response Tx -> Tx
forall a. Response a -> a
getResponseBody

        let tx :: Tx
tx = SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk Tx
depositTransaction
        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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx

        UTCTime
deadline <- NominalDiffTime
-> [HydraClient] -> (Value -> Maybe UTCTime) -> IO UTCTime
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 [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

        (Value -> Lovelace
selectLovelace (Value -> Lovelace)
-> (UTxOType Tx -> Value) -> UTxOType Tx -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Lovelace) -> IO (UTxOType Tx) -> 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))
-> IO (UTxOType Tx)
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
walletVk))
          IO Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace
0

        -- NOTE: we need to wait for the deadline to pass before we can recover the deposit
        DiffTime
diff <- NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> DiffTime)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline (UTCTime -> DiffTime) -> IO UTCTime -> IO DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime
diff DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
1

        (IO String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` String
"OK") (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"DELETE " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commits/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show (Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx))
            IO Request
-> (Request -> IO (Response String)) -> IO (Response String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response String)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
            IO (Response String) -> (Response String -> String) -> IO String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Response a -> a
getResponseBody @String

        NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
20 [HydraClient
n1] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"CommitRecovered"
          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
"recoveredUTxO" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (UTxO -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO
commitUTxO)

        (UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Value) -> IO (UTxOType Tx) -> IO Value
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))
-> IO (UTxOType Tx)
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
walletVk))
          IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue Lovelace
commitAmount
        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []

        UTCTime
deadline' <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
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 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
"HeadIsClosed"
          Value
v Value -> Getting (First UTCTime) Value UTCTime -> Maybe UTCTime
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
"contestationDeadline" ((Value -> Const (First UTCTime) Value)
 -> Value -> Const (First UTCTime) Value)
-> Getting (First UTCTime) Value UTCTime
-> Getting (First UTCTime) Value UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTCTime) Value UTCTime
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTCTime UTCTime
_JSON

        NominalDiffTime
remainingTime <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline' (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
remainingTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"ReadyToFanout" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId]
        HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Fanout" []
        NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
          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
"HeadIsFinalized"

        -- Assert final wallet balance
        (UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> ValueType Tx)
-> IO (UTxOType Tx) -> IO (ValueType Tx)
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))
-> IO (UTxOType Tx)
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
walletVk))
          IO (ValueType Tx) -> ValueType Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance UTxO
UTxOType Tx
commitUTxO
 where
  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

-- | Open a single-participant head, perform 3 deposits, and then:
-- 1. Close the head and recover deposit #1
-- 2. Fanout the head and recover deposit #2
-- 3. Open a new head and recover deposit #3
canRecoverDepositInAnyState :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canRecoverDepositInAnyState :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canRecoverDepositInAnyState 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
    -- NOTE: Directly expire deposits
    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
    -- Use short periods so deposits expire quickly
    let timing :: Timing
timing = Timing{NominalDiffTime
$sel:blockTime:Timing :: NominalDiffTime
blockTime :: NominalDiffTime
blockTime, $sel:contestationPeriod:Timing :: ContestationPeriod
contestationPeriod = ContestationPeriod
2, $sel:depositPeriod:Timing :: DepositPeriod
depositPeriod = DepositPeriod
1, $sel:depositActivation:Timing :: DepositPeriod
depositActivation = DepositPeriod
1}
    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
    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
      -- Init the head
      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])

      -- Get some L1 funds
      (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
      let commitAmount :: Lovelace
commitAmount = Lovelace
5_000_000
      UTxO
commitUTxO1 <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
commitAmount) ((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
commitUTxO2 <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
commitAmount) ((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
commitUTxO3 <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
commitAmount) ((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)

      VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue (Lovelace
commitAmount Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
* Lovelace
3)

      -- Increment commit #1
      (TxId, UTCTime)
depositReceipt1 <- HydraClient -> SigningKey PaymentKey -> UTxO -> IO (TxId, UTCTime)
increment HydraClient
n1 SigningKey PaymentKey
walletSk UTxO
commitUTxO1
      VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue (Lovelace
commitAmount Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
* Lovelace
2)

      -- Increment commit #2
      (TxId, UTCTime)
depositReceipt2 <- HydraClient -> SigningKey PaymentKey -> UTxO -> IO (TxId, UTCTime)
increment HydraClient
n1 SigningKey PaymentKey
walletSk UTxO
commitUTxO2
      VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue Lovelace
commitAmount

      -- Increment commit #3
      (TxId, UTCTime)
depositReceipt3 <- HydraClient -> SigningKey PaymentKey -> UTxO -> IO (TxId, UTCTime)
increment HydraClient
n1 SigningKey PaymentKey
walletSk UTxO
commitUTxO3
      Value -> Lovelace
selectLovelace (Value -> Lovelace) -> IO Value -> IO Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk IO Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace
0

      -- 1. Close the head
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []

      UTCTime
contestationDeadline <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
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 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
"HeadIsClosed"
        Value
v Value -> Getting (First UTCTime) Value UTCTime -> Maybe UTCTime
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
"contestationDeadline" ((Value -> Const (First UTCTime) Value)
 -> Value -> Const (First UTCTime) Value)
-> Getting (First UTCTime) Value UTCTime
-> Getting (First UTCTime) Value UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTCTime) Value UTCTime
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTCTime UTCTime
_JSON

      -- Recover deposit #1
      HydraClient -> (TxId, UTCTime) -> UTxO -> IO ()
recover HydraClient
n1 (TxId, UTCTime)
depositReceipt1 UTxO
commitUTxO1
      VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance UTxO
UTxOType Tx
commitUTxO1

      -- 2. Fanout the head
      NominalDiffTime
remainingTime <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
contestationDeadline (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
remainingTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"ReadyToFanout" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId]
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Fanout" []
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
        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
"HeadIsFinalized"

      -- Recover deposit #2
      HydraClient -> (TxId, UTCTime) -> UTxO -> IO ()
recover HydraClient
n1 (TxId, UTCTime)
depositReceipt2 UTxO
commitUTxO2
      VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO
commitUTxO1 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO2)

      -- 3. Open a new head
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Init" []
      HeadId
_headId2 <- 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])

      -- Recover deposit #3
      HydraClient -> (TxId, UTCTime) -> UTxO -> IO ()
recover HydraClient
n1 (TxId, UTCTime)
depositReceipt3 UTxO
commitUTxO3
      VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO
commitUTxO1 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO2 UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO3)
 where
  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

  queryWalletBalance :: VerificationKey PaymentKey -> IO Value
queryWalletBalance VerificationKey PaymentKey
walletVk =
    UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Value) -> IO (UTxOType Tx) -> IO Value
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))
-> IO (UTxOType Tx)
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
walletVk)

  increment :: HydraClient -> SigningKey PaymentKey -> UTxO -> IO (TxId, UTCTime)
  increment :: HydraClient -> SigningKey PaymentKey -> UTxO -> IO (TxId, UTCTime)
increment HydraClient
n SigningKey PaymentKey
walletSk UTxO
commitUTxO = do
    Tx
depositTransaction <-
      String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
        IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO
commitUTxO
          IO Request -> (Request -> IO (Response Tx)) -> IO (Response Tx)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response Tx)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
        IO (Response Tx) -> (Response Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response Tx -> Tx
forall a. Response a -> a
getResponseBody

    let tx :: Tx
tx = SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk Tx
depositTransaction
    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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx
    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

    UTCTime
deadline <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
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
n ((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

    (TxId, UTCTime) -> IO (TxId, UTCTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> TxBody Era -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx, UTCTime
deadline)

  recover :: HydraClient -> (TxId, UTCTime) -> UTxO -> IO ()
  recover :: HydraClient -> (TxId, UTCTime) -> UTxO -> IO ()
recover HydraClient
n (TxId
depositId, UTCTime
deadline) UTxO
commitUTxO = do
    -- NOTE: we need to wait for the deadline to pass before we can recover the deposit
    DiffTime
diff <- NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> DiffTime)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline (UTCTime -> DiffTime) -> IO UTCTime -> IO DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
    DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime
diff DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
1

    (IO String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` String
"OK") (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"DELETE " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commits/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
depositId)
        IO Request
-> (Request -> IO (Response String)) -> IO (Response String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response String)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
        IO (Response String) -> (Response String -> String) -> IO String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Response a -> a
getResponseBody @String
    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

    NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"CommitRecovered"
      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
"recoveredUTxO" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (UTxO -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO
commitUTxO)

-- | Open a two-participant head, stop one node so deposits stay pending, then
-- verify that GET /commits lists them. Recovery is covered by canRecoverDeposit.
canSeePendingDeposits :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canSeePendingDeposits :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canSeePendingDeposits 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
$
    (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
Bob) (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
      Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
Bob 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 [Actor
Bob] 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
      ChainConfig
bobChainConfig <-
        HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] 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
      Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2]
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        ()
_ <- Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> 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
_ <- NominalDiffTime
-> [HydraClient] -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] ((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, Party
bob])
          -- Stop Bob here so deposits stay pending (can't reach CommitFinalized without both nodes).
          () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
        UTxO
commitUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
5_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)
        UTxO
commitUTxO2 <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
4_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)

        -- Submit two deposits and check each appears in GET /commits immediately.
        [UTxO] -> (UTxO -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [UTxO
commitUTxO, UTxO
commitUTxO2] ((UTxO -> IO ()) -> IO ()) -> (UTxO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UTxO
utxo -> do
          Tx
depositTransaction <-
            String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
              IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO
utxo
                IO Request -> (Request -> IO (Response Tx)) -> IO (Response Tx)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response Tx)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
              IO (Response Tx) -> (Response Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response Tx -> Tx
forall a. Response a -> a
getResponseBody

          let tx :: Tx
tx = SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk Tx
depositTransaction
          let depositTxId :: TxId
depositTxId = TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx)
          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx

          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 [HydraClient
n1] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
            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"

          [TxId]
pendingDeposits <-
            String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"GET " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
hydraNodeBaseUrl HydraClient
n1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/commits")
              IO Request
-> (Request -> IO (Response [TxId])) -> IO (Response [TxId])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response [TxId])
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
              IO (Response [TxId]) -> (Response [TxId] -> [TxId]) -> IO [TxId]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response [TxId] -> [TxId]
forall a. Response a -> a
getResponseBody

          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [TxId]
pendingDeposits [TxId] -> [TxId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [TxId
depositTxId]
 where
  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

-- | Open a a single participant head with some UTxO and incrementally decommit it.
canDecommit :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canDecommit :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canDecommit 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
    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
      -- Initialize & open head
      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
walletVk, SigningKey PaymentKey
walletSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
      let headAmount :: Lovelace
headAmount = Lovelace
8_000_000
      let commitAmount :: Lovelace
commitAmount = Lovelace
5_000_000
      UTxO
headUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
headAmount) ((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
commitUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
walletVk (Lovelace -> Value
lovelaceToValue Lovelace
commitAmount) ((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
deposit <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 (UTxO
headUTxO UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
commitUTxO) IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx SigningKey PaymentKey
walletSk
      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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
deposit
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
deposit]

      -- Decommit the single commitUTxO by creating a fully "respending" decommit transaction
      let walletAddress :: AddressInEra Era
walletAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
walletVk
      Tx
decommitTx <- do
        let (TxIn
i, TxOut CtxUTxO Era
o) = [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a. HasCallStack => [a] -> a
List.head ([(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, TxOut CtxUTxO Era)] -> (TxIn, TxOut CtxUTxO Era)
forall a b. (a -> b) -> a -> b
$ UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO
commitUTxO
        (TxBodyError -> IO Tx)
-> (Tx -> IO Tx) -> Either TxBodyError Tx -> IO Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO Tx
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Tx)
-> (TxBodyError -> String) -> TxBodyError -> IO Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show) Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either TxBodyError Tx -> IO Tx) -> Either TxBodyError Tx -> IO Tx
forall a b. (a -> b) -> a -> b
$
          (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra Era, Value)
-> Secret (SigningKey PaymentKey)
-> Either TxBodyError Tx
mkSimpleTx (TxIn
i, TxOut CtxUTxO Era
o) (AddressInEra Era
walletAddress, TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
o) (SigningKey PaymentKey -> Secret (SigningKey PaymentKey)
forall a. a -> Secret a
mkSecret SigningKey PaymentKey
walletSk)

      HydraClient -> HeadId -> Tx -> NominalDiffTime -> IO ()
expectFailureOnUnsignedDecommitTx HydraClient
n1 HeadId
headId Tx
decommitTx NominalDiffTime
blockTime
      HydraClient -> HeadId -> Tx -> IO ()
expectSuccessOnSignedDecommitTx HydraClient
n1 HeadId
headId Tx
decommitTx

      -- After decommit Head UTxO should not contain decommitted outputs and wallet owns the funds on L1
      HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 UTxO
headUTxO
      (UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Value) -> IO (UTxOType Tx) -> IO Value
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))
-> IO (UTxOType Tx)
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
walletVk))
        IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue Lovelace
commitAmount

      -- Close and Fanout whatever is left in the Head back to L1
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []
      UTCTime
deadline <- NominalDiffTime
-> HydraClient -> (Value -> Maybe UTCTime) -> IO UTCTime
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 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
"HeadIsClosed"
        Value
v Value -> Getting (First UTCTime) Value UTCTime -> Maybe UTCTime
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
"contestationDeadline" ((Value -> Const (First UTCTime) Value)
 -> Value -> Const (First UTCTime) Value)
-> Getting (First UTCTime) Value UTCTime
-> Getting (First UTCTime) Value UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTCTime) Value UTCTime
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTCTime UTCTime
_JSON
      NominalDiffTime
remainingTime <- UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
remainingTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"ReadyToFanout" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId]
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Fanout" []
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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 ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
        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
"HeadIsFinalized"

      -- Assert final wallet balance
      (UTxOType Tx -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxOType Tx -> Value) -> IO (UTxOType Tx) -> IO Value
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))
-> IO (UTxOType Tx)
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
walletVk))
        IO Value -> Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace -> Value
lovelaceToValue (Lovelace
headAmount Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
+ Lovelace
commitAmount)
 where
  expectSuccessOnSignedDecommitTx :: HydraClient -> HeadId -> Tx -> IO ()
expectSuccessOnSignedDecommitTx HydraClient
n HeadId
headId Tx
decommitTx = do
    let decommitUTxO :: UTxO
decommitUTxO = Tx -> UTxO
utxoFromTx Tx
decommitTx
        decommitTxId :: TxIdType Tx
decommitTxId = Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
decommitTx
    -- Sometimes use websocket, sometimes use HTTP
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> (Gen (IO ()) -> IO (IO ())) -> Gen (IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (IO ()) -> IO (IO ())
forall a. Gen a -> IO a
generate (Gen (IO ()) -> IO ()) -> Gen (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      [IO ()] -> Gen (IO ())
forall a. HasCallStack => [a] -> Gen a
elements
        [ HydraClient -> Value -> IO ()
send HydraClient
n (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Decommit" [Key
"decommitTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
decommitTx]
        , HydraClient -> Tx -> IO ()
postDecommit HydraClient
n Tx
decommitTx
        ]
    HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text -> [Pair] -> Value
output Text
"DecommitRequested" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"decommitTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
decommitTx, Key
"utxoToDecommit" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
decommitUTxO]
    HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text -> [Pair] -> Value
output Text
"DecommitApproved" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"decommitTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TxId
TxIdType Tx
decommitTxId, Key
"utxoToDecommit" Key -> UTxO -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO
decommitUTxO]
    NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainBackendOptions -> UTxO -> IO ()
waitForUTxO ChainBackendOptions
opts UTxO
decommitUTxO

    UTxO
distributedUTxO <- NominalDiffTime
-> [HydraClient] -> (Value -> Maybe UTxO) -> IO UTxO
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 [HydraClient
n] ((Value -> Maybe UTxO) -> IO UTxO)
-> (Value -> Maybe UTxO) -> IO UTxO
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
"DecommitFinalized"
      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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
      Value
v Value -> Getting (First UTxO) Value UTxO -> Maybe UTxO
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
"distributedUTxO" ((Value -> Const (First UTxO) Value)
 -> Value -> Const (First UTxO) Value)
-> Getting (First UTxO) Value UTxO
-> Getting (First UTxO) Value UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First UTxO) Value UTxO
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value UTxO UTxO
_JSON

    Bool -> IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ UTxO
distributedUTxO UTxO -> [TxOut CtxUTxO Era] -> Bool
forall era. UTxO era -> [TxOut CtxUTxO era] -> Bool
`UTxO.containsOutputs` UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
decommitUTxO

  expectFailureOnUnsignedDecommitTx :: HydraClient -> HeadId -> Tx -> NominalDiffTime -> IO ()
  expectFailureOnUnsignedDecommitTx :: HydraClient -> HeadId -> Tx -> NominalDiffTime -> IO ()
expectFailureOnUnsignedDecommitTx HydraClient
n HeadId
headId Tx
decommitTx NominalDiffTime
blockTime = do
    let unsignedDecommitTx :: Tx
unsignedDecommitTx = [KeyWitness Era] -> TxBody Era -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] (TxBody Era -> Tx) -> TxBody Era -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
decommitTx
    -- Note: Just send to websocket, as that's how the following code checks
    -- that it failed. We could do the same for the HTTP endpoint, but doesn't
    -- quite seem worth the effort.
    HydraClient -> Value -> IO ()
send HydraClient
n (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Decommit" [Key
"decommitTx" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
unsignedDecommitTx]
    String
validationError <- NominalDiffTime
-> HydraClient -> (Value -> Maybe String) -> IO String
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
n ((Value -> Maybe String) -> IO String)
-> (Value -> Maybe String) -> IO String
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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
      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 (Text -> Value
Aeson.String Text
"DecommitInvalid")
      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
"decommitTx" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
unsignedDecommitTx)
      Value
v Value -> Getting (First String) Value String -> Maybe String
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
"decommitInvalidReason" ((Value -> Const (First String) Value)
 -> Value -> Const (First String) Value)
-> Getting (First String) Value String
-> Getting (First String) Value String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"validationError" ((Value -> Const (First String) Value)
 -> Value -> Const (First String) Value)
-> Getting (First String) Value String
-> Getting (First String) Value String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"reason" ((Value -> Const (First String) Value)
 -> Value -> Const (First String) Value)
-> Getting (First String) Value String
-> Getting (First String) Value String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First String) Value String
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value String String
_JSON

    String
validationError String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` String
"MissingVKeyWitnessesUTXOW"

  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

-- | Integration test for the SideLoadSnapshot API: open a single-party head,
-- deposit UTxO, side-load the deposit snapshot, then spend the deposited UTxO.
-- This exercises the real Cardano ledger and network to ensure the API inputs
-- and outputs are wired up correctly. The consensus-resumption logic is covered
-- by the BehaviorSpec unit tests.
canSideLoadSnapshot :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canSideLoadSnapshot :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canSideLoadSnapshot Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  (VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
aliceCardanoSk) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
Alice
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
  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

  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
    UTxO
aliceUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk (Lovelace -> Value
lovelaceToValue Lovelace
2_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)

    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])

    -- Deposit something and wait for it to be finalized on-chain
    Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 UTxO
aliceUTxO
    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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx
    HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]

    -- Side-load the deposit snapshot (sn=1)
    ConfirmedSnapshot Tx
snapshotConfirmed <- HydraClient -> IO (ConfirmedSnapshot Tx)
getSnapshotConfirmed HydraClient
n1
    HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"SideLoadSnapshot" [Key
"snapshot" Key -> ConfirmedSnapshot Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ConfirmedSnapshot Tx
snapshotConfirmed]
    NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
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 ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotSideLoaded"
      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
"snapshotNumber" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (Integer
1 :: Integer))

    -- After sideload, spending the deposited UTxO must work on the real ledger
    UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n1
    Tx
tx <- NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo Secret (SigningKey PaymentKey)
aliceCardanoSk VerificationKey PaymentKey
aliceCardanoVk
    HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
tx]
    NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
      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
"snapshot" Getting (First Value) Value Value
-> Getting (First Value) Value Value
-> Getting (First Value) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"number" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (Integer
2 :: Integer))
 where
  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

canResumeOnMemberAlreadyBootstrapped :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
canResumeOnMemberAlreadyBootstrapped :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
canResumeOnMemberAlreadyBootstrapped Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  let clients :: [Actor]
clients = [Actor
Alice, Actor
Bob]
  [(VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_aliceCardanoSk), (VerificationKey PaymentKey
bobCardanoVk, Secret (SigningKey PaymentKey)
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey)))
-> IO
     [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Actor]
clients Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk Lovelace
100_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)

  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
  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
  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 [Actor
Bob] 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
  ChainConfig
bobChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] 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
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2]
  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeCatchingUp Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    -- Node start up is a fixed cost (spawn, etcd bootstrap, websocket
    -- connect), not a blockTime multiple.
    NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
nodeStartupBudget HydraClient
n1 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"Greetings"
      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
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadStatus -> Value
forall a. ToJSON a => a -> Value
toJSON HeadStatus
Idle)
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeCatchingUp Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
nodeStartupBudget HydraClient
n2 ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"Greetings"
        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
"headStatus" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadStatus -> Value
forall a. ToJSON a => a -> Value
toJSON HeadStatus
Idle)
      DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
5

    String -> [String] -> IO ()
callProcess String
"rm" [String
"-rf", String
workDir String -> String -> String
</> String
"state-2"]
    DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1

    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeCatchingUp Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts (IO () -> HydraClient -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraClient -> IO ()) -> IO () -> HydraClient -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1)
      IO () -> Selector SomeException -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \(SomeException
e :: SomeException) ->
        ByteString
"hydra-node" ByteString -> ByteString -> Bool
`isInfixOf` SomeException -> ByteString
forall b a. (Show a, IsString b) => a -> b
show SomeException
e
          Bool -> Bool -> Bool
&& ByteString
"etcd" ByteString -> ByteString -> Bool
`isInfixOf` SomeException -> ByteString
forall b a. (Show a, IsString b) => a -> b
show SomeException
e

    -- Tell the fresh etcd to join the existing cluster instead of
    -- bootstrapping a new one. Scoped to this node's process environment; a
    -- process-global setEnv would leak into every other spawned node, since
    -- etcd children inherit the full environment.
    RunOptions
bobOptions <- HasCallStack =>
ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts Value -> Value
forall a. a -> a
id
    [(String, String)]
-> Tracer IO HydraNodeLog
-> String
-> Int
-> RunOptions
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
[(String, String)]
-> Tracer IO HydraNodeLog
-> String
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
withPreparedHydraNodeWithEnv [(String
"ETCD_INITIAL_CLUSTER_STATE", String
"existing")] Tracer IO HydraNodeLog
hydraTracer String
workDir Int
2 RunOptions
bobOptions (IO () -> HydraClient -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraClient -> IO ()) -> IO () -> HydraClient -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
 where
  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

-- XXX: restart scenarios require 3 party cluster in order to observe PeerDisconnected instead of NetworkDisconnected
waitsForChainInSync :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
waitsForChainInSync :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
waitsForChainInSync Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  let clients :: [Actor]
clients = [Actor
Alice, Actor
Bob, Actor
Carol]
  [(VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
_), (VerificationKey PaymentKey
bobCardanoVk, Secret (SigningKey PaymentKey)
_), (VerificationKey PaymentKey
carolCardanoVk, Secret (SigningKey PaymentKey)
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey)))
-> IO
     [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Actor]
clients Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk Lovelace
100_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)
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
carolCardanoVk Lovelace
100_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)

  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
  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
  let timing :: Timing
timing = NominalDiffTime -> Timing
mkTestTiming NominalDiffTime
blockTime
  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 [Actor
Bob, Actor
Carol] 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
  ChainConfig
bobChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Carol] 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
  ChainConfig
carolChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Carol String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Bob] 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

  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2, Int
3]
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk, VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
carolVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      -- Open a head while Carol online
      HeadId
headId <- Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO HeadId)
-> IO HeadId
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
carolChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO HeadId) -> IO HeadId)
-> (HydraClient -> IO HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> 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.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2, HydraClient
n3] ((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, Party
bob, Party
carol])

        -- Carol deposits something
        UTxO
carolUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
carolCardanoVk (Lovelace -> Value
lovelaceToValue Lovelace
2_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)
        Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n3 UTxO
carolUTxO
        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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient
n1, HydraClient
n2, HydraClient
n3] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]

        HeadId -> IO HeadId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadId
headId

      -- Carol disconnects and the others observe it
      NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
5 [HydraClient
n1, HydraClient
n2] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"PeerDisconnected"

      -- Wait for some blocks to roll forward
      let unsyncedPeriod :: UnsyncedPeriod
unsyncedPeriod = case ChainConfig
carolChainConfig of
            Cardano CardanoChainConfig{$sel:unsyncedPeriod:CardanoChainConfig :: CardanoChainConfig -> UnsyncedPeriod
unsyncedPeriod = UnsyncedPeriod
up} -> UnsyncedPeriod
up
            Offline{} -> ContestationPeriod -> UnsyncedPeriod
defaultUnsyncedPeriodFor (let Timing{$sel:contestationPeriod:Timing :: Timing -> ContestationPeriod
contestationPeriod = ContestationPeriod
cp} = Timing
timing in ContestationPeriod
cp)
      DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UnsyncedPeriod -> NominalDiffTime
unsyncedPeriodToNominalDiffTime UnsyncedPeriod
unsyncedPeriod NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
50 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime)

      -- Alice closes the head while Carol offline
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Close" []
      NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"HeadIsClosed"
        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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)

      -- Carol restarts
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeCatchingUp Tracer IO HydraNodeLog
hydraTracer ChainConfig
carolChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        -- Carol replays the Close during catch up, emitting NodeUnsynced,
        -- NodeSynced and HeadIsClosed from the same chain sync, while the
        -- Greetings is generated when the API client connects. Their order is
        -- not fixed: on a local devnet the catch-up can finish before the
        -- test client connects, delivering all three as history ahead of the
        -- Greetings, whereas on a slow run the Greetings comes first and the
        -- events arrive live; NodeSynced and HeadIsClosed can also swap, as
        -- the block holding the close tx can land on either side of the
        -- drift crossing. Since waitMatch consumes the message stream, a
        -- single scan collecting them in any order covers all interleavings.
        -- Only NodeSynced is order-constrained: it must come after
        -- NodeUnsynced, so the replayed pre-restart NodeSynced does not
        -- count.
        let catchUpBudget :: NominalDiffTime
catchUpBudget =
              NominalDiffTime
nodeStartupBudget NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ UnsyncedPeriod -> NominalDiffTime
unsyncedPeriodToNominalDiffTime UnsyncedPeriod
unsyncedPeriod NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime
            matchCatchUpProgress :: [Value] -> Value -> Maybe Value
matchCatchUpProgress [Value]
seen Value
v = do
              Value
tag <- 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"
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
tag Value -> [Value] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Value]
seen
              case Value
tag of
                Value
"Greetings" -> 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
"me" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Party -> Value
forall a. ToJSON a => a -> Value
toJSON Party
carol)
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (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
"hydraNodeVersion")
                  Value -> Maybe Value
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
tag
                Value
"HeadIsClosed" -> 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
"headId" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (HeadId -> Value
forall a. ToJSON a => a -> Value
toJSON HeadId
headId)
                  Value -> Maybe Value
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
tag
                Value
"NodeUnsynced" -> Value -> Maybe Value
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
tag
                Value
"NodeSynced" -> do
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
"NodeUnsynced" Value -> [Value] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Value]
seen
                  Value -> Maybe Value
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
tag
                Value
_ -> Maybe Value
forall a. Maybe a
Nothing
            collectCatchUpProgress :: [Value] -> IO ()
collectCatchUpProgress [Value]
seen
              | [Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
seen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              | Bool
otherwise = do
                  Value
tag <- NominalDiffTime
-> HydraClient -> (Value -> Maybe Value) -> IO Value
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
catchUpBudget HydraClient
n3 ([Value] -> Value -> Maybe Value
matchCatchUpProgress [Value]
seen)
                  [Value] -> IO ()
collectCatchUpProgress (Value
tag Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
seen)
        [Value] -> IO ()
collectCatchUpProgress []
 where
  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

-- | Three hydra nodes open a head and we assert that none of them sees errors if a party is duplicated.
threeNodesWithMirrorParty :: Tracer IO EndToEndLog -> FilePath -> ChainBackendOptions -> [TxId] -> IO ()
threeNodesWithMirrorParty :: Tracer IO EndToEndLog
-> String -> ChainBackendOptions -> [TxId] -> IO ()
threeNodesWithMirrorParty Tracer IO EndToEndLog
tracer String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId = do
  let parties :: [Actor]
parties = [Actor
Alice, Actor
Bob]

  [(VerificationKey PaymentKey
aliceCardanoVk, Secret (SigningKey PaymentKey)
aliceCardanoSk), (VerificationKey PaymentKey
bobCardanoVk, Secret (SigningKey PaymentKey)
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey)))
-> IO
     [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Actor]
parties Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk Lovelace
100_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)
  ChainBackendOptions
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk Lovelace
100_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)
  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
  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
  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 [Actor
Bob] 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
  ChainConfig
bobChainConfig <-
    HasCallStack =>
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
Actor
-> String
-> ChainBackendOptions
-> [TxId]
-> [Actor]
-> Timing
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir ChainBackendOptions
opts [TxId]
hydraScriptsTxId [Actor
Alice] 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
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
1, Int
2, Int
3]
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
1 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
bobChainConfig String
workDir Int
2 Secret (SigningKey HydraKey)
bobSk [VerificationKey HydraKey
aliceVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      -- One party will participate using same hydra credentials
      Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> String
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
blockTime ChainConfig
aliceChainConfig String
workDir Int
3 Secret (SigningKey HydraKey)
aliceSk [VerificationKey HydraKey
bobVk] Map Int HydraNodePorts
nodePorts ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        let clients :: [HydraClient]
clients = [HydraClient
n1, HydraClient
n2, HydraClient
n3]
        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.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient]
clients ((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, Party
bob])

        -- N1 & N3 deposit the same thing at the same time
        -- XXX: one will fail but the head will still be usable
        UTxO
aliceUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
aliceCardanoVk (Lovelace -> Value
lovelaceToValue Lovelace
2_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)
        (String, IO ()) -> (String, IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (String, m b) -> m ()
raceLabelled_
          ( String
"request-commit-tx-n1"
          , (HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n1 UTxO
aliceUTxO IO Tx -> (Tx -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx
tx -> 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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx)
              IO () -> (SubmitTransactionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SubmitTransactionException
_ :: SubmitTransactionException) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          )
          ( String
"request-commit-tx-n3"
          , (HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n3 UTxO
aliceUTxO IO Tx -> (Tx -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx
tx -> 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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
tx)
              IO () -> (SubmitTransactionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SubmitTransactionException
_ :: SubmitTransactionException) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          )

        -- N2 deposits something
        UTxO
bobUTxO <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
bobCardanoVk (Lovelace -> Value
lovelaceToValue Lovelace
2_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)
        Tx
depositTx <- HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient
n2 UTxO
bobUTxO
        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 -> m ()
forall (m :: * -> *). ChainBackend m => Tx -> m ()
submitTransaction Tx
depositTx

        -- Wait for at least bob's deposit to be finalized
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (Timing -> NominalDiffTime
depositTimeout Timing
timing) [HydraClient]
clients (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"CommitFinalized" [Key
"headId" Key -> HeadId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HeadId
headId, Key
"depositTxId" Key -> TxId -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
depositTx]

        -- N3 performs a simple transaction from N3 to itself
        UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n3
        Tx
tx <- NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo Secret (SigningKey PaymentKey)
aliceCardanoSk VerificationKey PaymentKey
aliceCardanoVk
        HydraClient -> Value -> IO ()
send HydraClient
n3 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
tx]

        -- Everyone confirms the tx snapshot (number depends on how many deposits succeeded)
        NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
200 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient]
clients ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
          Integer
snNum <- Value
v Value -> Getting (First Integer) Value Integer -> Maybe Integer
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
"snapshot" ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"number" ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Integer) Value Integer
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism' Value Integer
_JSON :: Maybe Integer
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Integer
snNum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1
          -- Check that confirmed list is non-empty (tx was included)
          [Value]
confirmed <- 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
"snapshot" ((Value -> Const (First [Value]) Value)
 -> Value -> Const (First [Value]) Value)
-> Getting (First [Value]) Value [Value]
-> Getting (First [Value]) Value [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"confirmed" ((Value -> Const (First [Value]) Value)
 -> Value -> Const (First [Value]) Value)
-> Getting (First [Value]) Value [Value]
-> Getting (First [Value]) Value [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First [Value]) Value [Value]
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value [Value] [Value]
_JSON :: Maybe [Value]
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
confirmed)

      -- \| Mirror party N3 disconnects and the others observe it
      NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
100 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"PeerDisconnected"

      -- N1 performs another simple transaction from N1 to itself
      UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
n1
      Tx
tx <- NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO
utxo Secret (SigningKey PaymentKey)
aliceCardanoSk VerificationKey PaymentKey
aliceCardanoVk
      HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
tx]

      -- Everyone confirms it (snapshot number depends on previous deposits)
      NominalDiffTime -> [HydraClient] -> (Value -> Maybe ()) -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch (NominalDiffTime
200 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
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
"SnapshotConfirmed"
        Integer
snNum <- Value
v Value -> Getting (First Integer) Value Integer -> Maybe Integer
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
"snapshot" ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"number" ((Value -> Const (First Integer) Value)
 -> Value -> Const (First Integer) Value)
-> Getting (First Integer) Value Integer
-> Getting (First Integer) Value Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Integer) Value Integer
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism' Value Integer
_JSON :: Maybe Integer
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Integer
snNum Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
2
        [Value]
confirmed <- 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
"snapshot" ((Value -> Const (First [Value]) Value)
 -> Value -> Const (First [Value]) Value)
-> Getting (First [Value]) Value [Value]
-> Getting (First [Value]) Value [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"confirmed" ((Value -> Const (First [Value]) Value)
 -> Value -> Const (First [Value]) Value)
-> Getting (First [Value]) Value [Value]
-> Getting (First [Value]) Value [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First [Value]) Value [Value]
forall t a b. (AsJSON t, FromJSON a, ToJSON b) => Prism t t a b
forall a b. (FromJSON a, ToJSON b) => Prism Value Value a b
Prism Value Value [Value] [Value]
_JSON :: Maybe [Value]
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
confirmed)

-- * L2 scenarios

-- | Respend all outputs owned by a given key in the head every 'delay' seconds,
-- for 'numTimes' times.
respendNTimes :: HasCallStack => HydraClient -> Secret (SigningKey PaymentKey) -> DiffTime -> Int -> IO ()
respendNTimes :: HasCallStack =>
HydraClient
-> Secret (SigningKey PaymentKey) -> DiffTime -> Int -> IO ()
respendNTimes HydraClient
client Secret (SigningKey PaymentKey)
sk DiffTime
delay Int
numTimes = do
  UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
client
  Int -> UTxO -> IO ()
respend Int
numTimes UTxO
utxo
 where
  vk :: VerificationKey PaymentKey
vk = Secret (SigningKey PaymentKey) -> VerificationKey PaymentKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey PaymentKey)
sk

  respend :: Int -> UTxO -> IO ()
respend !Int
n UTxO
utxo
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | Bool
otherwise = do
        Tx
tx <- NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO
-> Secret (SigningKey PaymentKey)
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
testNetworkId UTxO
utxo Secret (SigningKey PaymentKey)
sk VerificationKey PaymentKey
vk
        UTxO
utxo' <- Tx -> IO UTxO
submitToHead (Secret (SigningKey PaymentKey) -> Tx -> Tx
forall s. CanSignTx s => s -> Tx -> Tx
signTx Secret (SigningKey PaymentKey)
sk Tx
tx)
        DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
delay
        Int -> UTxO -> IO ()
respend (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) UTxO
utxo'

  submitToHead :: Tx -> IO UTxO
submitToHead Tx
tx = do
    HydraClient -> Value -> IO ()
send HydraClient
client (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"NewTx" [Key
"transaction" Key -> Tx -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Tx
tx]
    NominalDiffTime -> HydraClient -> (Value -> Maybe UTxO) -> IO UTxO
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
10 HydraClient
client ((Value -> Maybe UTxO) -> IO UTxO)
-> (Value -> Maybe UTxO) -> IO UTxO
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
"SnapshotConfirmed"
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
        Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
tx
          Value -> [Value] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (Value
v Value -> Getting (Endo [Value]) Value Value -> [Value]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"snapshot" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"confirmed" Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
-> Getting (Endo [Value]) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Value]) Value Value
forall t. AsValue t => IndexedTraversal' Int t Value
IndexedTraversal' Int Value Value
values)
      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
"snapshot" Getting (First Value) Value Value
-> Getting (First Value) Value Value
-> Getting (First Value) Value Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"utxo" Maybe Value -> (Value -> Maybe UTxO) -> Maybe UTxO
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 UTxO) -> Value -> Maybe UTxO
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser UTxO
forall a. FromJSON a => Value -> Parser a
parseJSON

-- * Utilities

-- | Refuel given 'Actor' with given 'Lovelace' if current marked UTxO is below that amount.
refuelIfNeeded ::
  Tracer IO EndToEndLog ->
  ChainBackendOptions ->
  Actor ->
  Coin ->
  IO ()
refuelIfNeeded :: Tracer IO EndToEndLog
-> ChainBackendOptions -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
actor Lovelace
amount = do
  (VerificationKey PaymentKey
actorVk, Secret (SigningKey PaymentKey)
_) <- Actor
-> IO (VerificationKey PaymentKey, Secret (SigningKey PaymentKey))
keysFor Actor
actor
  UTxO
existingUtxo <- 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
$ QueryPoint -> VerificationKey PaymentKey -> m UTxO
forall (m :: * -> *).
ChainBackend m =>
QueryPoint -> VerificationKey PaymentKey -> m UTxO
queryUTxOFor QueryPoint
QueryTip VerificationKey PaymentKey
actorVk
  Tracer IO EndToEndLog -> EndToEndLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO EndToEndLog
tracer (EndToEndLog -> IO ()) -> EndToEndLog -> IO ()
forall a b. (a -> b) -> a -> b
$ StartingFunds{$sel:actor:ClusterOptions :: String
actor = Actor -> String
actorName Actor
actor, $sel:utxo:ClusterOptions :: UTxO
utxo = UTxO
existingUtxo}
  let currentBalance :: Lovelace
currentBalance = Value -> Lovelace
selectLovelace (Value -> Lovelace) -> Value -> Lovelace
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance @Tx UTxO
UTxOType Tx
existingUtxo
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lovelace
currentBalance Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
< Lovelace
amount) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    UTxO
utxo <- ChainBackendOptions
-> VerificationKey PaymentKey
-> Value
-> Tracer IO FaucetLog
-> IO UTxO
seedFromFaucet ChainBackendOptions
opts VerificationKey PaymentKey
actorVk (Lovelace -> Value
lovelaceToValue Lovelace
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)
    Tracer IO EndToEndLog -> EndToEndLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO EndToEndLog
tracer (EndToEndLog -> IO ()) -> EndToEndLog -> IO ()
forall a b. (a -> b) -> a -> b
$ RefueledFunds{$sel:actor:ClusterOptions :: String
actor = Actor -> String
actorName Actor
actor, $sel:refuelingAmount:ClusterOptions :: Lovelace
refuelingAmount = Lovelace
amount, UTxO
$sel:utxo:ClusterOptions :: UTxO
utxo :: UTxO
utxo}

-- | Return the remaining funds to the faucet
returnFundsToFaucet ::
  Tracer IO EndToEndLog ->
  ChainBackendOptions ->
  Actor ->
  IO ()
returnFundsToFaucet :: Tracer IO EndToEndLog -> ChainBackendOptions -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer ChainBackendOptions
opts Actor
actor = do
  Tracer IO FaucetLog -> ChainBackendOptions -> Actor -> IO ()
Faucet.returnFundsToFaucet ((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) ChainBackendOptions
opts Actor
actor

headIsOpenWith :: Set Party -> Value -> Maybe HeadId
headIsOpenWith :: Set Party -> Value -> Maybe HeadId
headIsOpenWith Set Party
expectedParties 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
"HeadIsOpen"
  Set Party
parties <- 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
"parties" Maybe Value -> (Value -> Maybe (Set Party)) -> Maybe (Set Party)
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 (Set Party)) -> Value -> Maybe (Set Party)
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (Set Party)
forall a. FromJSON a => Value -> Parser a
parseJSON
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Set Party
parties Set Party -> Set Party -> Bool
forall a. Eq a => a -> a -> Bool
== Set Party
expectedParties
  Value
headId <- 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
"headId"
  (Value -> Parser HeadId) -> Value -> Maybe HeadId
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser HeadId
forall a. FromJSON a => Value -> Parser a
parseJSON Value
headId

headIsFinalizedWith :: HeadId -> UTxO -> Value -> Maybe ()
headIsFinalizedWith :: HeadId -> UTxO -> Value -> Maybe ()
headIsFinalizedWith HeadId
expectedHeadId UTxO
expectedUTxO 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
"HeadIsFinalized"
  HeadId
headId' <- 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
"headId" Maybe Value -> (Value -> Maybe HeadId) -> Maybe HeadId
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 HeadId) -> Value -> Maybe HeadId
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser HeadId
forall a. FromJSON a => Value -> Parser a
parseJSON
  UTxO
finalizedUTxO' <- 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
"finalizedUTxO" Maybe Value -> (Value -> Maybe UTxO) -> Maybe UTxO
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 UTxO) -> Value -> Maybe UTxO
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser UTxO
forall a. FromJSON a => Value -> Parser a
parseJSON :: Maybe UTxO
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (HeadId
headId' HeadId -> HeadId -> Bool
forall a. Eq a => a -> a -> Bool
== HeadId
expectedHeadId)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((TxOut CtxUTxO Era -> Bool) -> [TxOut CtxUTxO Era] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TxOut CtxUTxO Era -> [TxOut CtxUTxO Era] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
finalizedUTxO') (UTxO -> [TxOut CtxUTxO Era]
forall era. UTxO era -> [TxOut CtxUTxO era]
UTxO.txOutputs UTxO
expectedUTxO))

expectErrorStatus ::
  -- | Expected http status code
  Int ->
  -- | Optional string expected to be present somewhere in the response body
  Maybe ByteString ->
  -- | Expected exception
  HttpException ->
  Bool
expectErrorStatus :: Int -> Maybe ByteString -> Selector HttpException
expectErrorStatus
  Int
stat
  Maybe ByteString
mbodyContains
  ( VanillaHttpException
      ( L.HttpExceptionRequest
          Request
_
          (L.StatusCodeException Response ()
response ByteString
chunk)
        )
    ) =
    Response () -> Status
forall body. Response body -> Status
L.responseStatus Response ()
response Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Status
forall a. Enum a => Int -> a
toEnum Int
stat Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> Bool
B.null ByteString
chunk) Bool -> Bool -> Bool
&& Maybe ByteString -> ByteString -> Bool
assertBodyContains Maybe ByteString
mbodyContains ByteString
chunk
   where
    -- NOTE: The documentation says: Response body parameter MAY include the beginning of the response body so this can be partial.
    -- https://hackage.haskell.org/package/http-client-0.7.13.1/docs/Network-HTTP-Client.html#t:HttpExceptionContent
    assertBodyContains :: Maybe ByteString -> ByteString -> Bool
    assertBodyContains :: Maybe ByteString -> ByteString -> Bool
assertBodyContains (Just ByteString
bodyContains) ByteString
bodyChunk = ByteString
bodyContains ByteString -> ByteString -> Bool
`isInfixOf` ByteString
bodyChunk
    assertBodyContains Maybe ByteString
Nothing ByteString
_ = Bool
False
expectErrorStatus Int
_ Maybe ByteString
_ HttpException
_ = Bool
False

-- | Get the base URL for HTTP API calls to a hydra-node, using the actual
-- API port the node was started on (allocated dynamically by
-- 'allocateHydraNodePorts').
hydraNodeBaseUrl :: HydraClient -> String
hydraNodeBaseUrl :: HydraClient -> String
hydraNodeBaseUrl HydraClient{Host
$sel:apiHost:HydraClient :: HydraClient -> Host
apiHost :: Host
apiHost} =
  String
"http://127.0.0.1:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PortNumber -> String
forall b a. (Show a, IsString b) => a -> b
show (Host -> PortNumber
Network.port Host
apiHost)

-- | An 'Option' carrying a hydra-node's actual API port. Use to set
-- the port in a 'Network.HTTP.Req.req' call.
hydraApiPort :: HydraClient -> Option scheme
hydraApiPort :: forall (scheme :: Scheme). HydraClient -> Option scheme
hydraApiPort HydraClient{Host
$sel:apiHost:HydraClient :: HydraClient -> Host
apiHost :: Host
apiHost} = Int -> Option scheme
forall (scheme :: Scheme). Int -> Option scheme
port (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Host -> PortNumber
Network.port Host
apiHost))