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

module Hydra.Cluster.Scenarios where

import Hydra.Prelude
import Test.Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Tx (hashScriptIntegrity)
import Cardano.Ledger.Api (RewardAccount (..), 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.Credential (Credential (ScriptHashObj))
import Cardano.Ledger.Plutus.Language (Language (PlutusV3))
import CardanoClient (
  QueryPoint (QueryTip),
  RunningNode (..),
  buildTransaction,
  buildTransactionWithPParams,
  queryTip,
  queryUTxOFor,
  submitTx,
  waitForUTxO,
 )
import CardanoNode (NodeLog)
import Control.Concurrent.Async (mapConcurrently_)
import Control.Lens ((.~), (?~), (^.), (^..), (^?))
import Data.Aeson (Value, object, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (atKey, key, values, _JSON, _String)
import Data.Aeson.Types (parseMaybe)
import Data.ByteString (isInfixOf)
import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BSC
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Hydra.API.HTTPServer (
  DraftCommitTxResponse (..),
  TransactionSubmitted (..),
 )
import Hydra.Cardano.Api (
  Coin (..),
  Era,
  File (File),
  Key (SigningKey),
  KeyWitnessInCtx (..),
  LedgerProtocolParameters (..),
  PaymentKey,
  Tx,
  TxId,
  UTxO,
  addTxIns,
  addTxInsCollateral,
  addTxOuts,
  createAndValidateTransactionBody,
  defaultTxBodyContent,
  fromLedgerTx,
  getTxBody,
  getTxId,
  getVerificationKey,
  lovelaceToValue,
  makeSignedTransaction,
  mkScriptAddress,
  mkScriptDatum,
  mkScriptWitness,
  mkTxIn,
  mkTxOutAutoBalance,
  mkTxOutDatumHash,
  mkVkAddress,
  scriptWitnessInCtx,
  selectLovelace,
  setTxProtocolParams,
  signTx,
  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.Cluster.Faucet (FaucetLog, 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.Mithril (MithrilLog)
import Hydra.Cluster.Options (Options)
import Hydra.Cluster.Util (chainConfigFor, keysFor, modifyConfig, setNetworkId)
import Hydra.Contract.Dummy (dummyRewardingScript)
import Hydra.Ledger.Cardano (mkSimpleTx, mkTransferTx, unsafeBuildTransaction)
import Hydra.Ledger.Cardano.Evaluate (maxTxExecutionUnits)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Options (DirectChainConfig (..), startChainFrom)
import Hydra.Tx (HeadId, IsTx (balance), Party, txId)
import Hydra.Tx.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod), fromNominalDiffTime)
import Hydra.Tx.DepositDeadline (DepositDeadline (..))
import Hydra.Tx.Utils (dummyValidatorScript, verificationKeyToOnChainId)
import HydraNode (
  HydraClient (..),
  HydraNodeLog,
  getProtocolParameters,
  getSnapshotConfirmed,
  getSnapshotLastSeen,
  getSnapshotUTxO,
  input,
  output,
  postDecommit,
  prepareHydraNode,
  requestCommitTx,
  send,
  waitFor,
  waitForAllMatch,
  waitForNodesConnected,
  waitMatch,
  withHydraCluster,
  withHydraNode,
  withPreparedHydraNode,
 )
import Network.HTTP.Conduit (parseUrlThrow)
import Network.HTTP.Conduit qualified as L
import Network.HTTP.Req (
  HttpException (VanillaHttpException),
  JsonResponse,
  POST (POST),
  ReqBodyJson (ReqBodyJson),
  defaultHttpConfig,
  http,
  port,
  req,
  responseBody,
  runReq,
  (/:),
 )
import Network.HTTP.Simple (getResponseBody, httpJSON, setRequestBodyJSON)
import Network.HTTP.Types (urlEncode)
import System.FilePath ((</>))
import Test.Hydra.Tx.Fixture (testNetworkId)
import Test.Hydra.Tx.Gen (genKeyPair)
import Test.QuickCheck (choose, elements, generate)

data EndToEndLog
  = ClusterOptions {EndToEndLog -> Options
options :: Options}
  | FromCardanoNode NodeLog
  | FromFaucet FaucetLog
  | FromHydraNode HydraNodeLog
  | FromMithril MithrilLog
  | StartingFunds {EndToEndLog -> String
actor :: String, EndToEndLog -> UTxO' (TxOut CtxUTxO Era)
utxo :: UTxO}
  | RefueledFunds {actor :: String, EndToEndLog -> Lovelace
refuelingAmount :: Coin, utxo :: UTxO}
  | RemainingFunds {actor :: String, utxo :: UTxO}
  | PublishedHydraScriptsAt {EndToEndLog -> [TxId]
hydraScriptsTxId :: [TxId]}
  | UsingHydraScriptsAt {hydraScriptsTxId :: [TxId]}
  | CreatedKey {EndToEndLog -> String
keyPath :: FilePath}
  deriving stock (EndToEndLog -> EndToEndLog -> Bool
(EndToEndLog -> EndToEndLog -> Bool)
-> (EndToEndLog -> EndToEndLog -> Bool) -> Eq EndToEndLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EndToEndLog -> EndToEndLog -> Bool
== :: EndToEndLog -> EndToEndLog -> Bool
$c/= :: EndToEndLog -> EndToEndLog -> Bool
/= :: EndToEndLog -> EndToEndLog -> Bool
Eq, Int -> EndToEndLog -> ShowS
[EndToEndLog] -> ShowS
EndToEndLog -> String
(Int -> EndToEndLog -> ShowS)
-> (EndToEndLog -> String)
-> ([EndToEndLog] -> ShowS)
-> Show EndToEndLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EndToEndLog -> ShowS
showsPrec :: Int -> EndToEndLog -> ShowS
$cshow :: EndToEndLog -> String
show :: EndToEndLog -> String
$cshowList :: [EndToEndLog] -> ShowS
showList :: [EndToEndLog] -> ShowS
Show, (forall x. EndToEndLog -> Rep EndToEndLog x)
-> (forall x. Rep EndToEndLog x -> EndToEndLog)
-> Generic EndToEndLog
forall x. Rep EndToEndLog x -> EndToEndLog
forall x. EndToEndLog -> Rep EndToEndLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EndToEndLog -> Rep EndToEndLog x
from :: forall x. EndToEndLog -> Rep EndToEndLog x
$cto :: forall x. Rep EndToEndLog x -> EndToEndLog
to :: forall x. Rep EndToEndLog x -> EndToEndLog
Generic)
  deriving anyclass ([EndToEndLog] -> Value
[EndToEndLog] -> Encoding
EndToEndLog -> Bool
EndToEndLog -> Value
EndToEndLog -> Encoding
(EndToEndLog -> Value)
-> (EndToEndLog -> Encoding)
-> ([EndToEndLog] -> Value)
-> ([EndToEndLog] -> Encoding)
-> (EndToEndLog -> Bool)
-> ToJSON EndToEndLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: EndToEndLog -> Value
toJSON :: EndToEndLog -> Value
$ctoEncoding :: EndToEndLog -> Encoding
toEncoding :: EndToEndLog -> Encoding
$ctoJSONList :: [EndToEndLog] -> Value
toJSONList :: [EndToEndLog] -> Value
$ctoEncodingList :: [EndToEndLog] -> Encoding
toEncodingList :: [EndToEndLog] -> Encoding
$comitField :: EndToEndLog -> Bool
omitField :: EndToEndLog -> Bool
ToJSON)

oneOfThreeNodesStopsForAWhile :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
oneOfThreeNodesStopsForAWhile :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
oneOfThreeNodesStopsForAWhile Tracer IO EndToEndLog
tracer String
workDir RunningNode
cardanoNode [TxId]
hydraScriptsTxId = do
  let clients :: [Actor]
clients = [Actor
Alice, Actor
Bob, Actor
Carol]
  [(VerificationKey PaymentKey
aliceCardanoVk, SigningKey PaymentKey
aliceCardanoSk), (VerificationKey PaymentKey
bobCardanoVk, SigningKey PaymentKey
_), (VerificationKey PaymentKey
carolCardanoVk, SigningKey PaymentKey
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, SigningKey PaymentKey))
-> IO [(VerificationKey PaymentKey, 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, SigningKey PaymentKey)
keysFor
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)

  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
10
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Bob, Actor
Carol] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Carol] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Carol String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Bob] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk, VerificationKey HydraKey
carolVk] [Int
1, Int
2, Int
3] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    UTxO' (TxOut CtxUTxO Era)
aliceUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
cardanoNode VerificationKey PaymentKey
aliceCardanoVk Lovelace
1_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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
carolVk] [Int
1, Int
2, Int
3] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
carolChainConfig String
workDir Int
3 SigningKey HydraKey
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] [Int
1, Int
2, Int
3] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        -- Init
        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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob, Party
carol])

        -- Alice commits something
        HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode

        -- Everyone else commits nothing
        (HydraClient -> IO ()) -> [HydraClient] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ (\HydraClient
n -> HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode) [HydraClient
n2, HydraClient
n3]

        -- Observe open with the relevant UTxOs
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2, HydraClient
n3] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
aliceUTxO, 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]

        -- Perform a simple transaction from alice to herself
        UTxO' (TxOut CtxUTxO Era)
utxo <- HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1
        Tx
tx <- NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO' (TxOut CtxUTxO Era)
utxo 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
        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
1 :: 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' (TxOut CtxUTxO Era)
utxo <- HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1
      Tx
tx <- NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO' (TxOut CtxUTxO Era)
utxo 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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
carolChainConfig String
workDir Int
3 SigningKey HydraKey
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] [Int
1, Int
2, Int
3] ((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
2 :: 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
  RunningNode{SocketPath
nodeSocket :: SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket, NetworkId
networkId :: NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId, NominalDiffTime
blockTime :: NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime} = RunningNode
cardanoNode
  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 -> RunningNode -> [TxId] -> IO ()
restartedNodeCanObserveCommitTx :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
restartedNodeCanObserveCommitTx Tracer IO EndToEndLog
tracer String
workDir RunningNode
cardanoNode [TxId]
hydraScriptsTxId = do
  let clients :: [Actor]
clients = [Actor
Alice, Actor
Bob]
  [(VerificationKey PaymentKey
aliceCardanoVk, SigningKey PaymentKey
_), (VerificationKey PaymentKey
bobCardanoVk, SigningKey PaymentKey
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, SigningKey PaymentKey))
-> IO [(VerificationKey PaymentKey, 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, SigningKey PaymentKey)
keysFor
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)

  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
1 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk] [Int
1, Int
2] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    HeadId
headId <- Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO HeadId)
-> IO HeadId
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
2 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int
1, Int
2] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob])

    -- n1 does a commit while n2 is down
    HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode
    HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text -> [Pair] -> Value
output Text
"Committed" [Key
"party" Key -> Party -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Party
bob, Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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]

    -- n2 is back and does observe the commit
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
2 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int
1, Int
2] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n2] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"Committed" [Key
"party" Key -> Party -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Party
bob, Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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]
 where
  RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId} = RunningNode
cardanoNode

restartedNodeCanAbort :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
restartedNodeCanAbort :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
restartedNodeCanAbort Tracer IO EndToEndLog
tracer String
workDir RunningNode
cardanoNode [TxId]
hydraScriptsTxId = do
  Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
cardanoNode Actor
Alice Lovelace
100_000_000
  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
2
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      -- 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
<&> (DirectChainConfig -> DirectChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\DirectChainConfig
config -> DirectChainConfig
config{networkId, 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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO HeadId)
-> IO HeadId
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [] [Int
1] ((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" []
    -- XXX: might need to tweak the wait time
    NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch 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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [] [Int
1] ((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 HydraClient
n1 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsInitializingWith ([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
    HydraClient -> Value -> IO ()
send HydraClient
n1 (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Pair] -> Value
input Text
"Abort" []
    HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
20 [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text -> [Pair] -> Value
output Text
"HeadIsAborted" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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
headId2]
 where
  RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId} = RunningNode
cardanoNode

-- | 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 ->
  RunningNode ->
  [TxId] ->
  IO ()
singlePartyHeadFullLifeCycle :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
singlePartyHeadFullLifeCycle Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice
        Tracer IO EndToEndLog -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
AliceFunds
  )
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
55_000_000
      -- Start hydra-node on chain tip
      ChainPoint
tip <- NetworkId -> SocketPath -> IO ChainPoint
queryTip NetworkId
networkId SocketPath
nodeSocket
      ContestationPeriod
contestationPeriod <- NominalDiffTime -> IO ContestationPeriod
forall (m :: * -> *).
MonadFail m =>
NominalDiffTime -> m ContestationPeriod
fromNominalDiffTime (NominalDiffTime -> IO ContestationPeriod)
-> NominalDiffTime -> IO ContestationPeriod
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
10 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime
      let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
      ChainConfig
aliceChainConfig <-
        HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
          IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (DirectChainConfig -> DirectChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\DirectChainConfig
config -> DirectChainConfig
config{networkId, startChainFrom = Just tip})
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [] [Int
1] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

        -- Commit something from external key
        (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
AliceFunds
        Lovelace
amount <- Integer -> Lovelace
Coin (Integer -> Lovelace) -> IO Integer -> IO Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer -> IO Integer
forall a. Gen a -> IO a
generate ((Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
10_000_000, Integer
50_000_000))
        UTxO' (TxOut CtxUTxO Era)
utxoToCommit <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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)
        HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
utxoToCommit IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node

        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
utxoToCommit, 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]
        -- 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
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"
          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] (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] ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ HeadId -> UTxO' (TxOut CtxUTxO Era) -> Value -> Maybe ()
checkFanout HeadId
headId UTxO' (TxOut CtxUTxO Era)
utxoToCommit
      Actor -> IO ()
traceRemainingFunds Actor
Alice
      Actor -> IO ()
traceRemainingFunds Actor
AliceFunds
 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

  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

  traceRemainingFunds :: Actor -> IO ()
traceRemainingFunds Actor
actor = do
    (VerificationKey PaymentKey
actorVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
actor
    UTxO' (TxOut CtxUTxO Era)
utxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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' (TxOut CtxUTxO Era)
$sel:utxo:ClusterOptions :: UTxO' (TxOut CtxUTxO Era)
utxo :: UTxO' (TxOut CtxUTxO Era)
utxo}

-- | Open a Hydra Head with only a single participant but some arbitrary UTxO
-- committed.
singlePartyOpenAHead ::
  Tracer IO EndToEndLog ->
  FilePath ->
  RunningNode ->
  [TxId] ->
  -- | Continuation called when the head is open
  (HydraClient -> SigningKey PaymentKey -> HeadId -> IO a) ->
  IO a
singlePartyOpenAHead :: forall a.
Tracer IO EndToEndLog
-> String
-> RunningNode
-> [TxId]
-> (HydraClient -> SigningKey PaymentKey -> HeadId -> IO a)
-> IO a
singlePartyOpenAHead Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [TxId]
hydraScriptsTxId HydraClient -> 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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
25_000_000
    -- Start hydra-node on chain tip
    ChainPoint
tip <- NetworkId -> SocketPath -> IO ChainPoint
queryTip NetworkId
networkId SocketPath
nodeSocket
    let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
    let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
        IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (DirectChainConfig -> DirectChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\DirectChainConfig
config -> DirectChainConfig
config{networkId, 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 -> ShowS
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
$sel:keyPath:ClusterOptions :: String
keyPath :: String
keyPath}

    UTxO' (TxOut CtxUTxO Era)
utxoToCommit <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [] [Int
1] ((HydraClient -> IO a) -> IO a) -> (HydraClient -> IO a) -> IO a
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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])
      HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
utxoToCommit IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
utxoToCommit, 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 -> SigningKey PaymentKey -> HeadId -> IO a
callback HydraClient
n1 SigningKey PaymentKey
walletSk HeadId
headId
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

-- | Single hydra-node where the commit is done using some wallet UTxO.
singlePartyCommitsFromExternal ::
  Tracer IO EndToEndLog ->
  FilePath ->
  RunningNode ->
  [TxId] ->
  IO ()
singlePartyCommitsFromExternal :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
singlePartyCommitsFromExternal Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice
        Tracer IO EndToEndLog -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
AliceFunds
  )
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
25_000_000
      let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
      let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
      ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
1] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

        (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
AliceFunds
        UTxO' (TxOut CtxUTxO Era)
utxoToCommit <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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' (TxOut CtxUTxO Era))
-> 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' (TxOut CtxUTxO Era)
-> ReqBodyJson (UTxO' (TxOut CtxUTxO Era))
forall a. a -> ReqBodyJson a
ReqBodyJson UTxO' (TxOut CtxUTxO Era)
utxoToCommit)
              (Proxy (JsonResponse (DraftCommitTxResponse Tx))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse (DraftCommitTxResponse Tx)))
              (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
port (Int -> Option 'Http) -> Int -> Option 'Http
forall a b. (a -> b) -> a -> b
$ Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

        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
        RunningNode -> Tx -> IO ()
submitTx RunningNode
node (Tx -> IO ()) -> Tx -> IO ()
forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk Tx
commitTx

        Maybe Value
lockedUTxO <- NominalDiffTime
-> HydraClient
-> (Value -> Maybe (Maybe Value))
-> IO (Maybe Value)
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 (Maybe Value)) -> IO (Maybe Value))
-> (Value -> Maybe (Maybe Value)) -> IO (Maybe Value)
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 Value
"HeadIsOpen"
          Maybe Value -> Maybe (Maybe Value)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Maybe (Maybe Value))
-> Maybe Value -> Maybe (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
"utxo"
        Maybe Value
lockedUTxO Maybe Value -> Maybe Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Value -> Maybe Value
forall a. a -> Maybe a
Just (UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
utxoToCommit)
 where
  RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

singlePartyUsesScriptOnL2 ::
  Tracer IO EndToEndLog ->
  FilePath ->
  RunningNode ->
  [TxId] ->
  IO ()
singlePartyUsesScriptOnL2 :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
singlePartyUsesScriptOnL2 Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice
        Tracer IO EndToEndLog -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
AliceFunds
  )
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
250_000_000
      let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
      let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
1
      ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
1] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

        (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
AliceFunds

        -- Create money on L1
        let commitAmount :: Lovelace
commitAmount = Lovelace
100_000_000
        UTxO' (TxOut CtxUTxO Era)
utxoToCommit <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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)

        -- Push it into L2
        HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
utxoToCommit
          IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk 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 -> do
            RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
tx

        -- 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 (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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
utxoToCommit, 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]

        PParams StandardConway
pparams <- HydraClient -> IO (PParams (ShelleyLedgerEra Era))
getProtocolParameters HydraClient
n1

        -- 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 StandardConway
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

        Right Tx
tx <- PParams (ShelleyLedgerEra Era)
-> NetworkId
-> SocketPath
-> AddressInEra Era
-> UTxO' (TxOut CtxUTxO Era)
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams (ShelleyLedgerEra Era)
PParams StandardConway
pparams NetworkId
networkId SocketPath
nodeSocket (NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
walletVk) UTxO' (TxOut CtxUTxO Era)
utxoToCommit [] [TxOut CtxTx Era
scriptOutput]

        let signedL2tx :: Tx
signedL2tx = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx 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 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 Era
body =
              TxBodyContent BuildTx Era
defaultTxBodyContent
                TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
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 Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall era build.
IsAlonzoBasedEra era =>
[TxIn] -> TxBodyContent build era -> TxBodyContent build era
addTxInsCollateral [TxIn
remainder]
                TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era]
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
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 Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
BuildTxWith build (Maybe (LedgerProtocolParameters era))
-> TxBodyContent build era -> TxBodyContent build era
setTxProtocolParams (Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Maybe (LedgerProtocolParameters Era)
 -> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era)))
-> Maybe (LedgerProtocolParameters Era)
-> BuildTxWith BuildTx (Maybe (LedgerProtocolParameters Era))
forall a b. (a -> b) -> a -> b
$ LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a. a -> Maybe a
Just (LedgerProtocolParameters Era
 -> Maybe (LedgerProtocolParameters Era))
-> LedgerProtocolParameters Era
-> Maybe (LedgerProtocolParameters Era)
forall a b. (a -> b) -> a -> b
$ PParams (ShelleyLedgerEra Era) -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams (ShelleyLedgerEra Era)
PParams StandardConway
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 utxoToCommit
        TxBody
txBody <- (TxBodyError -> IO TxBody)
-> (TxBody -> IO TxBody) -> Either TxBodyError TxBody -> IO TxBody
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO TxBody
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO TxBody)
-> (TxBodyError -> String) -> TxBodyError -> IO TxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show) TxBody -> IO TxBody
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBodyContent BuildTx Era -> Either TxBodyError TxBody
createAndValidateTransactionBody TxBodyContent BuildTx Era
body)

        let spendTx' :: Tx
spendTx' = [KeyWitness Era] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody
txBody
            spendTx :: Tx
spendTx = Tx (ShelleyLedgerEra Era) -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx (ShelleyLedgerEra Era) -> Tx)
-> Tx (ShelleyLedgerEra Era) -> Tx
forall a b. (a -> b) -> a -> b
$ PParams StandardConway
-> [Language]
-> Tx (ShelleyLedgerEra Era)
-> Tx (ShelleyLedgerEra Era)
forall ppera txera.
(AlonzoEraPParams ppera, AlonzoEraTxWits txera,
 AlonzoEraTxBody txera, EraTx txera) =>
PParams ppera -> [Language] -> Tx txera -> Tx txera
recomputeIntegrityHash PParams StandardConway
pparams [Language
PlutusV3] (Tx -> Tx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
spendTx')
        let signedTx :: Tx
signedTx = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx 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 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
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
        (UTxO' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Value)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

-- | Open a head and run a script using 'Rewarding' script purpose and a zero
-- lovelace withdrawal.
singlePartyUsesWithdrawZeroTrick :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
singlePartyUsesWithdrawZeroTrick :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
singlePartyUsesWithdrawZeroTrick Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
250_000_000) (Tracer IO EndToEndLog -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Seed/return funds
    (VerificationKey PaymentKey
walletVk, SigningKey PaymentKey
walletSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
AliceFunds
    IO (UTxO' (TxOut CtxUTxO Era))
-> (UTxO' (TxOut CtxUTxO Era) -> IO ())
-> (UTxO' (TxOut CtxUTxO Era) -> 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
      (RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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' (TxOut CtxUTxO Era)
_ -> Tracer IO EndToEndLog -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
AliceFunds)
      ((UTxO' (TxOut CtxUTxO Era) -> IO ()) -> IO ())
-> (UTxO' (TxOut CtxUTxO Era) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UTxO' (TxOut CtxUTxO Era)
utxoToCommit -> do
        -- Start hydra-node and open a head
        let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
        let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
1
        ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
        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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
1] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])
          HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
utxoToCommit IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
utxoToCommit, 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]

          -- Prepare a tx that re-spends everything owned by walletVk
          PParams StandardConway
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 <- PParams (ShelleyLedgerEra Era)
-> NetworkId
-> SocketPath
-> AddressInEra Era
-> UTxO' (TxOut CtxUTxO Era)
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransactionWithPParams PParams (ShelleyLedgerEra Era)
PParams StandardConway
pparams NetworkId
networkId SocketPath
nodeSocket AddressInEra Era
change UTxO' (TxOut CtxUTxO Era)
utxoToCommit [] []

          -- Modify the tx to run a script via the withdraw 0 trick
          let redeemer :: Data StandardConway
redeemer = ScriptRedeemer -> Data StandardConway
forall era. Era era => ScriptRedeemer -> Data era
toLedgerData (ScriptRedeemer -> Data StandardConway)
-> ScriptRedeemer -> Data StandardConway
forall a b. (a -> b) -> a -> b
$ () -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData ()
              exUnits :: ExUnits
exUnits = ExecutionUnits -> ExUnits
toLedgerExUnits ExecutionUnits
maxTxExecutionUnits
              rewardAccount :: RewardAccount StandardCrypto
rewardAccount = Network
-> Credential 'Staking StandardCrypto
-> RewardAccount StandardCrypto
forall c. Network -> Credential 'Staking c -> RewardAccount c
RewardAccount Network
Testnet (ScriptHash StandardCrypto -> Credential 'Staking StandardCrypto
forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash StandardCrypto
scriptHash)
              scriptHash :: ScriptHash (EraCrypto StandardConway)
scriptHash = Script StandardConway -> ScriptHash (EraCrypto StandardConway)
forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript Script StandardConway
AlonzoScript StandardConway
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 (ShelleyLedgerEra Era) -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx (Tx (ShelleyLedgerEra Era) -> Tx)
-> Tx (ShelleyLedgerEra Era) -> Tx
forall a b. (a -> b) -> a -> b
$
                  PParams StandardConway
-> [Language]
-> Tx (ShelleyLedgerEra Era)
-> Tx (ShelleyLedgerEra Era)
forall ppera txera.
(AlonzoEraPParams ppera, AlonzoEraTxWits txera,
 AlonzoEraTxBody txera, EraTx txera) =>
PParams ppera -> [Language] -> Tx txera -> Tx txera
recomputeIntegrityHash PParams StandardConway
pparams [Language
PlutusV3] (Tx (ShelleyLedgerEra Era) -> Tx (ShelleyLedgerEra Era))
-> Tx (ShelleyLedgerEra Era) -> Tx (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$
                    Tx -> Tx (ShelleyLedgerEra Era)
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx
                      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((Set (TxIn (EraCrypto StandardConway))
     -> Identity (Set (TxIn StandardCrypto)))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (Set (TxIn (EraCrypto StandardConway))
    -> Identity (Set (TxIn StandardCrypto)))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (TxIn (EraCrypto StandardConway))
 -> Identity (Set (TxIn StandardCrypto)))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
(Set (TxIn (EraCrypto StandardConway))
 -> Identity (Set (TxIn (EraCrypto StandardConway))))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardConway) (Set (TxIn (EraCrypto StandardConway)))
collateralInputsTxBodyL ((Set (TxIn (EraCrypto StandardConway))
  -> Identity (Set (TxIn StandardCrypto)))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> Set (TxIn StandardCrypto)
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (TxIn -> TxIn StandardCrypto)
-> Set TxIn -> Set (TxIn StandardCrypto)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map TxIn -> TxIn StandardCrypto
toLedgerTxIn (UTxO' (TxOut CtxUTxO Era) -> Set TxIn
forall out. UTxO' out -> Set TxIn
UTxO.inputSet UTxO' (TxOut CtxUTxO Era)
utxoToCommit)
                      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe Lovelace)
Lens' (TxBody StandardConway) (StrictMaybe Lovelace)
totalCollateralTxBodyL ((StrictMaybe Lovelace -> Identity (StrictMaybe Lovelace))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> StrictMaybe Lovelace
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Lovelace -> StrictMaybe Lovelace
forall a. a -> StrictMaybe a
SJust ((TxOut CtxUTxO Era -> Lovelace)
-> UTxO' (TxOut CtxUTxO Era) -> Lovelace
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Value -> Lovelace
selectLovelace (Value -> Lovelace)
-> (TxOut CtxUTxO Era -> Value) -> TxOut CtxUTxO Era -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) UTxO' (TxOut CtxUTxO Era)
utxoToCommit)
                      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxBody StandardConway -> Identity (TxBody StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxBody StandardConway -> Identity (TxBody StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardConway) (TxBody StandardConway)
bodyTxL ((TxBody StandardConway -> Identity (TxBody StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((Withdrawals (EraCrypto StandardConway)
     -> Identity (Withdrawals StandardCrypto))
    -> TxBody StandardConway -> Identity (TxBody StandardConway))
-> (Withdrawals (EraCrypto StandardConway)
    -> Identity (Withdrawals StandardCrypto))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals (EraCrypto StandardConway)
 -> Identity (Withdrawals StandardCrypto))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
(Withdrawals (EraCrypto StandardConway)
 -> Identity (Withdrawals (EraCrypto StandardConway)))
-> TxBody StandardConway -> Identity (TxBody StandardConway)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Withdrawals (EraCrypto era))
Lens'
  (TxBody StandardConway) (Withdrawals (EraCrypto StandardConway))
withdrawalsTxBodyL ((Withdrawals (EraCrypto StandardConway)
  -> Identity (Withdrawals StandardCrypto))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> Withdrawals StandardCrypto
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (RewardAccount StandardCrypto) Lovelace
-> Withdrawals StandardCrypto
forall c. Map (RewardAccount c) Lovelace -> Withdrawals c
Withdrawals (RewardAccount StandardCrypto
-> Lovelace -> Map (RewardAccount StandardCrypto) Lovelace
forall k a. k -> a -> Map k a
Map.singleton RewardAccount StandardCrypto
rewardAccount Lovelace
0)
                      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> AlonzoTx StandardConway)
-> AlonzoTx StandardConway
forall a b. a -> (a -> b) -> b
& (TxWits StandardConway -> Identity (TxWits StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxWits StandardConway -> Identity (TxWits StandardConway))
-> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx StandardConway) (TxWits StandardConway)
witsTxL ((TxWits StandardConway -> Identity (TxWits StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> ((Redeemers StandardConway
     -> Identity (Redeemers StandardConway))
    -> TxWits StandardConway -> Identity (TxWits StandardConway))
-> (Redeemers StandardConway
    -> Identity (Redeemers StandardConway))
-> AlonzoTx StandardConway
-> Identity (AlonzoTx StandardConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers StandardConway -> Identity (Redeemers StandardConway))
-> TxWits StandardConway -> Identity (TxWits StandardConway)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits StandardConway) (Redeemers StandardConway)
rdmrsTxWitsL ((Redeemers StandardConway -> Identity (Redeemers StandardConway))
 -> AlonzoTx StandardConway -> Identity (AlonzoTx StandardConway))
-> Redeemers StandardConway
-> AlonzoTx StandardConway
-> AlonzoTx StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map
  (PlutusPurpose AsIx StandardConway) (Data StandardConway, ExUnits)
-> Redeemers StandardConway
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (ConwayPlutusPurpose AsIx StandardConway
-> (Data StandardConway, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx StandardConway)
     (Data StandardConway, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton (AsIx Word32 (RewardAccount (EraCrypto StandardConway))
-> ConwayPlutusPurpose AsIx StandardConway
forall (f :: * -> * -> *) era.
f Word32 (RewardAccount (EraCrypto era))
-> ConwayPlutusPurpose f era
ConwayRewarding (AsIx Word32 (RewardAccount (EraCrypto StandardConway))
 -> ConwayPlutusPurpose AsIx StandardConway)
-> AsIx Word32 (RewardAccount (EraCrypto StandardConway))
-> ConwayPlutusPurpose AsIx StandardConway
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 (RewardAccount StandardCrypto)
forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data StandardConway
redeemer, ExUnits
exUnits))
                      AlonzoTx StandardConway
-> (AlonzoTx StandardConway -> Tx (ShelleyLedgerEra Era))
-> Tx (ShelleyLedgerEra Era)
forall a b. a -> (a -> b) -> b
& (TxWits StandardConway -> Identity (TxWits StandardConway))
-> Tx StandardConway -> Identity (Tx StandardConway)
(TxWits StandardConway -> Identity (TxWits StandardConway))
-> AlonzoTx StandardConway -> Identity (Tx (ShelleyLedgerEra Era))
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx StandardConway) (TxWits StandardConway)
witsTxL ((TxWits StandardConway -> Identity (TxWits StandardConway))
 -> AlonzoTx StandardConway -> Identity (Tx (ShelleyLedgerEra Era)))
-> ((Map
       (ScriptHash (EraCrypto StandardConway)) (Script StandardConway)
     -> Identity
          (Map (ScriptHash StandardCrypto) (AlonzoScript StandardConway)))
    -> TxWits StandardConway -> Identity (TxWits StandardConway))
-> (Map
      (ScriptHash (EraCrypto StandardConway)) (Script StandardConway)
    -> Identity
         (Map (ScriptHash StandardCrypto) (AlonzoScript StandardConway)))
-> AlonzoTx StandardConway
-> Identity (Tx (ShelleyLedgerEra Era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map
   (ScriptHash (EraCrypto StandardConway)) (Script StandardConway)
 -> Identity
      (Map (ScriptHash StandardCrypto) (AlonzoScript StandardConway)))
-> TxWits StandardConway -> Identity (TxWits StandardConway)
(Map
   (ScriptHash (EraCrypto StandardConway)) (Script StandardConway)
 -> Identity
      (Map
         (ScriptHash (EraCrypto StandardConway)) (Script StandardConway)))
-> TxWits StandardConway -> Identity (TxWits StandardConway)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map (ScriptHash (EraCrypto era)) (Script era))
Lens'
  (TxWits StandardConway)
  (Map
     (ScriptHash (EraCrypto StandardConway)) (Script StandardConway))
scriptTxWitsL ((Map
    (ScriptHash (EraCrypto StandardConway)) (Script StandardConway)
  -> Identity
       (Map (ScriptHash StandardCrypto) (AlonzoScript StandardConway)))
 -> AlonzoTx StandardConway -> Identity (Tx (ShelleyLedgerEra Era)))
-> Map (ScriptHash StandardCrypto) (AlonzoScript StandardConway)
-> AlonzoTx StandardConway
-> Tx (ShelleyLedgerEra Era)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptHash StandardCrypto
-> AlonzoScript StandardConway
-> Map (ScriptHash StandardCrypto) (AlonzoScript StandardConway)
forall k a. k -> a -> Map k a
Map.singleton ScriptHash StandardCrypto
scriptHash AlonzoScript StandardConway
script

          let signedL2tx :: Tx
signedL2tx = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx 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 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)
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

-- | 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 txera ->
  Ledger.Tx txera
recomputeIntegrityHash :: forall ppera txera.
(AlonzoEraPParams ppera, AlonzoEraTxWits txera,
 AlonzoEraTxBody txera, EraTx txera) =>
PParams ppera -> [Language] -> Tx txera -> Tx txera
recomputeIntegrityHash PParams ppera
pp [Language]
languages Tx txera
tx = do
  Tx txera
tx Tx txera -> (Tx txera -> Tx txera) -> Tx txera
forall a b. a -> (a -> b) -> b
& (TxBody txera -> Identity (TxBody txera))
-> Tx txera -> Identity (Tx txera)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx txera) (TxBody txera)
bodyTxL ((TxBody txera -> Identity (TxBody txera))
 -> Tx txera -> Identity (Tx txera))
-> ((StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
     -> Identity (StrictMaybe (ScriptIntegrityHash (EraCrypto txera))))
    -> TxBody txera -> Identity (TxBody txera))
-> (StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
    -> Identity (StrictMaybe (ScriptIntegrityHash (EraCrypto txera))))
-> Tx txera
-> Identity (Tx txera)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
 -> Identity (StrictMaybe (ScriptIntegrityHash (EraCrypto txera))))
-> TxBody txera -> Identity (TxBody txera)
forall era.
AlonzoEraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era)))
Lens'
  (TxBody txera)
  (StrictMaybe (ScriptIntegrityHash (EraCrypto txera)))
scriptIntegrityHashTxBodyL ((StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
  -> Identity (StrictMaybe (ScriptIntegrityHash (EraCrypto txera))))
 -> Tx txera -> Identity (Tx txera))
-> StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
-> Tx txera
-> Tx txera
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
integrityHash
 where
  integrityHash :: StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
integrityHash =
    Set LangDepView
-> Redeemers txera
-> TxDats txera
-> StrictMaybe (ScriptIntegrityHash (EraCrypto txera))
forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era
-> TxDats era
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
hashScriptIntegrity
      ([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)
      (Tx txera
tx Tx txera
-> Getting (Redeemers txera) (Tx txera) (Redeemers txera)
-> Redeemers txera
forall s a. s -> Getting a s a -> a
^. (TxWits txera -> Const (Redeemers txera) (TxWits txera))
-> Tx txera -> Const (Redeemers txera) (Tx txera)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx txera) (TxWits txera)
witsTxL ((TxWits txera -> Const (Redeemers txera) (TxWits txera))
 -> Tx txera -> Const (Redeemers txera) (Tx txera))
-> ((Redeemers txera -> Const (Redeemers txera) (Redeemers txera))
    -> TxWits txera -> Const (Redeemers txera) (TxWits txera))
-> Getting (Redeemers txera) (Tx 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)
      (Tx txera
tx Tx txera
-> Getting (TxDats txera) (Tx txera) (TxDats txera) -> TxDats txera
forall s a. s -> Getting a s a -> a
^. (TxWits txera -> Const (TxDats txera) (TxWits txera))
-> Tx txera -> Const (TxDats txera) (Tx txera)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx txera) (TxWits txera)
witsTxL ((TxWits txera -> Const (TxDats txera) (TxWits txera))
 -> Tx txera -> Const (TxDats txera) (Tx txera))
-> ((TxDats txera -> Const (TxDats txera) (TxDats txera))
    -> TxWits txera -> Const (TxDats txera) (TxWits txera))
-> Getting (TxDats txera) (Tx 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)

singlePartyCommitsScriptBlueprint ::
  Tracer IO EndToEndLog ->
  FilePath ->
  RunningNode ->
  [TxId] ->
  IO ()
singlePartyCommitsScriptBlueprint :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
singlePartyCommitsScriptBlueprint Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
20_000_000
    let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
    let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
    ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
    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
    (VerificationKey PaymentKey
_, SigningKey PaymentKey
walletSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
AliceFunds
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
1] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

      (Value
clientPayload, UTxO' (TxOut CtxUTxO Era)
scriptUTxO) <- Lovelace -> IO (Value, UTxO' (TxOut CtxUTxO Era))
prepareScriptPayload Lovelace
3_000_000

      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))
            (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
port (Int -> Option 'Http) -> Int -> Option 'Http
forall a b. (a -> b) -> a -> b
$ Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

      let commitTx :: HttpResponseBody (JsonResponse Tx)
commitTx = JsonResponse Tx -> HttpResponseBody (JsonResponse Tx)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody JsonResponse Tx
res
      RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
HttpResponseBody (JsonResponse Tx)
commitTx

      Maybe Value
lockedUTxO <- NominalDiffTime
-> HydraClient
-> (Value -> Maybe (Maybe Value))
-> IO (Maybe Value)
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 (Maybe Value)) -> IO (Maybe Value))
-> (Value -> Maybe (Maybe Value)) -> IO (Maybe Value)
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 Value
"HeadIsOpen"
        Maybe Value -> Maybe (Maybe Value)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Maybe (Maybe Value))
-> Maybe Value -> Maybe (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
"utxo"
      Maybe Value
lockedUTxO Maybe Value -> Maybe Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Value -> Maybe Value
forall a. a -> Maybe a
Just (UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
scriptUTxO)
      -- incrementally commit script to a running Head
      (Value
clientPayload', UTxO' (TxOut CtxUTxO Era)
scriptUTxO') <- Lovelace -> IO (Value, UTxO' (TxOut CtxUTxO Era))
prepareScriptPayload Lovelace
2_000_000

      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))
            (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
port (Int -> Option 'Http) -> Int -> Option 'Http
forall a b. (a -> b) -> a -> b
$ Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

      let depositTransaction :: HttpResponseBody (JsonResponse Tx)
depositTransaction = JsonResponse Tx -> HttpResponseBody (JsonResponse Tx)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody JsonResponse Tx
res'
      let tx :: Tx
tx = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk Tx
HttpResponseBody (JsonResponse Tx)
depositTransaction

      RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
tx

      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n1] (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' (TxOut CtxUTxO Era) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era)
scriptUTxO']
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [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 -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx)]

      HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1 IO (UTxO' (TxOut CtxUTxO Era))
-> UTxO' (TxOut CtxUTxO Era) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxO' (TxOut CtxUTxO Era)
scriptUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
scriptUTxO'
 where
  prepareScriptPayload :: Lovelace -> IO (Value, UTxO' (TxOut CtxUTxO Era))
prepareScriptPayload Lovelace
lovelaceAmt = do
    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 Era
datumHash = () -> TxOutDatum ctx Era
forall era a ctx.
(ToScriptData a, IsAlonzoBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumHash ()
    (TxIn
scriptIn, TxOut CtxUTxO Era
scriptOut) <- RunningNode
-> AddressInEra Era
-> TxOutDatum CtxTx Era
-> Value
-> IO (TxIn, TxOut CtxUTxO Era)
createOutputAtAddress RunningNode
node AddressInEra Era
scriptAddress TxOutDatum CtxTx Era
forall ctx. TxOutDatum ctx
datumHash (Lovelace -> Value
lovelaceToValue Lovelace
lovelaceAmt)
    let scriptUTxO :: UTxO' (TxOut CtxUTxO Era)
scriptUTxO = (TxIn, TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall out. (TxIn, out) -> UTxO' out
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 spendingTx :: Tx
spendingTx =
          HasCallStack => TxBodyContent BuildTx Era -> Tx
TxBodyContent BuildTx Era -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx Era -> Tx)
-> TxBodyContent BuildTx Era -> Tx
forall a b. (a -> b) -> a -> b
$
            TxBodyContent BuildTx Era
defaultTxBodyContent
              TxBodyContent BuildTx Era
-> (TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era)
-> TxBodyContent BuildTx Era
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era
-> TxBodyContent BuildTx Era -> TxBodyContent BuildTx Era
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns [(TxIn
scriptIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
scriptWitness)]
    (Value, UTxO' (TxOut CtxUTxO Era))
-> IO (Value, UTxO' (TxOut CtxUTxO Era))
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
spendingTx
          , Key
"utxo" Key -> UTxO' (TxOut CtxUTxO Era) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era)
scriptUTxO
          ]
      , UTxO' (TxOut CtxUTxO Era)
scriptUTxO
      )

  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

persistenceCanLoadWithEmptyCommit ::
  Tracer IO EndToEndLog ->
  FilePath ->
  RunningNode ->
  [TxId] ->
  IO ()
persistenceCanLoadWithEmptyCommit :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
persistenceCanLoadWithEmptyCommit Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
20_000_000
    let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
    let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
    ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
    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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO HeadId)
-> IO HeadId
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
1] ((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" []
      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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

      HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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]
      HeadId -> IO HeadId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadId
headId
    let persistenceState :: String
persistenceState = String
workDir String -> ShowS
</> String
"state-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId String -> ShowS
</> String
"state"
    ByteString
stateContents <- String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
readFileBS String
persistenceState
    let headOpened :: ByteString
headOpened = String -> ByteString
BSC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
List.last (String -> [String]
List.lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BSC.unpack ByteString
stateContents)
    case ByteString
headOpened ByteString -> Getting (First Text) ByteString Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' ByteString Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"stateChanged" ((Value -> Const (First Text) Value)
 -> ByteString -> Const (First Text) ByteString)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> Getting (First Text) ByteString Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"tag" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> (Text -> Const (First Text) Text)
-> Value
-> Const (First Text) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Value -> Const (First Text) Value
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String of
      Maybe Text
Nothing -> Text -> IO ()
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Failed to find HeadIsOpened in the state file"
      Just Text
headIsOpen -> do
        Text
headIsOpen Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
"HeadOpened"
        Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
1] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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 -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1 IO (UTxO' (TxOut CtxUTxO Era))
-> UTxO' (TxOut CtxUTxO Era) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty
 where
  RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

-- | Single hydra-node where the commit is done from a raw transaction
-- blueprint.
singlePartyCommitsFromExternalTxBlueprint ::
  Tracer IO EndToEndLog ->
  FilePath ->
  RunningNode ->
  [TxId] ->
  IO ()
singlePartyCommitsFromExternalTxBlueprint :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
singlePartyCommitsFromExternalTxBlueprint Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
20_000_000
    let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
    let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
    ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
    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
    (VerificationKey PaymentKey
someExternalVk, SigningKey PaymentKey
someExternalSk) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
1] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])

      UTxO' (TxOut CtxUTxO Era)
someUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
someExternalVk Lovelace
10_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' (TxOut CtxUTxO Era)
utxoToCommit <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
someExternalVk 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 someAddress :: AddressInEra Era
someAddress = NetworkId -> VerificationKey PaymentKey -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> VerificationKey PaymentKey -> AddressInEra era
mkVkAddress NetworkId
networkId VerificationKey PaymentKey
someExternalVk
      let someOutput :: TxOut CtxTx Era
someOutput =
            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
someAddress
              (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
      NetworkId
-> SocketPath
-> AddressInEra Era
-> UTxO' (TxOut CtxUTxO Era)
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction NetworkId
networkId SocketPath
nodeSocket AddressInEra Era
someAddress UTxO' (TxOut CtxUTxO Era)
utxoToCommit ((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' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO Era)
someUTxO) [TxOut CtxTx Era
someOutput] 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 -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] (TxBody -> Tx) -> TxBody -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx
          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
unsignedTx
                  , Key
"utxo" Key -> UTxO' (TxOut CtxUTxO Era) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era)
utxoToCommit
                  ]
          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))
                (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
port (Int -> Option 'Http) -> Int -> Option 'Http
forall a b. (a -> b) -> a -> b
$ Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

          let commitTx :: HttpResponseBody (JsonResponse Tx)
commitTx = JsonResponse Tx -> HttpResponseBody (JsonResponse Tx)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody JsonResponse Tx
res
          let signedTx :: Tx
signedTx = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
someExternalSk Tx
HttpResponseBody (JsonResponse Tx)
commitTx
          RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
signedTx

          Maybe Value
lockedUTxO <- NominalDiffTime
-> HydraClient
-> (Value -> Maybe (Maybe Value))
-> IO (Maybe Value)
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 (Maybe Value)) -> IO (Maybe Value))
-> (Value -> Maybe (Maybe Value)) -> IO (Maybe Value)
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 Value
"HeadIsOpen"
            Maybe Value -> Maybe (Maybe Value)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Maybe (Maybe Value))
-> Maybe Value -> Maybe (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
"utxo"
          Maybe Value
lockedUTxO Maybe Value -> Maybe Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Value -> Maybe Value
forall a. a -> Maybe a
Just (UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
utxoToCommit)
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

-- | 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 ->
  RunningNode ->
  [TxId] ->
  IO ()
canCloseWithLongContestationPeriod :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
canCloseWithLongContestationPeriod Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [TxId]
hydraScriptsTxId = do
  Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
100_000_000
  -- Start hydra-node on chain tip
  ChainPoint
tip <- NetworkId -> SocketPath -> IO ChainPoint
queryTip NetworkId
networkId SocketPath
nodeSocket
  let oneWeek :: ContestationPeriod
oneWeek = Natural -> ContestationPeriod
UnsafeContestationPeriod (Natural
60 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
60 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
24 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
7)
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
oneWeek DepositDeadline
depositDeadline
      IO ChainConfig -> (ChainConfig -> ChainConfig) -> IO ChainConfig
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (DirectChainConfig -> DirectChainConfig)
-> ChainConfig -> ChainConfig
modifyConfig (\DirectChainConfig
config -> DirectChainConfig
config{networkId, 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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [] [Int
1] ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice])
    -- Commit nothing for now
    HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
    HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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]
    -- 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
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

  traceRemainingFunds :: Actor -> IO ()
traceRemainingFunds Actor
actor = do
    (VerificationKey PaymentKey
actorVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
actor
    UTxO' (TxOut CtxUTxO Era)
utxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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' (TxOut CtxUTxO Era)
$sel:utxo:ClusterOptions :: UTxO' (TxOut CtxUTxO Era)
utxo :: UTxO' (TxOut CtxUTxO Era)
utxo}

canSubmitTransactionThroughAPI ::
  Tracer IO EndToEndLog ->
  FilePath ->
  RunningNode ->
  [TxId] ->
  IO ()
canSubmitTransactionThroughAPI :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
canSubmitTransactionThroughAPI Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
25_000_000
    let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
    let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
    ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
    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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
aliceSk [] [Int
hydraNodeId] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
_ -> do
      -- let's prepare a _user_ transaction from Bob to Carol
      (VerificationKey PaymentKey
cardanoBobVk, SigningKey PaymentKey
cardanoBobSk) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Bob
      (VerificationKey PaymentKey
cardanoCarolVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Carol
      -- create output for Bob to be sent to carol
      UTxO' (TxOut CtxUTxO Era)
bobUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
cardanoBobVk 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
      NetworkId
-> SocketPath
-> AddressInEra Era
-> UTxO' (TxOut CtxUTxO Era)
-> [TxIn]
-> [TxOut CtxTx Era]
-> IO (Either (TxBodyErrorAutoBalance Era) Tx)
buildTransaction NetworkId
networkId SocketPath
nodeSocket AddressInEra Era
bobsAddress UTxO' (TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO Era)
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 -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] (TxBody -> Tx) -> TxBody -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx
          let unsignedRequest :: Value
unsignedRequest = Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
unsignedTx
          Int -> Value -> IO (JsonResponse TransactionSubmitted)
forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
Int -> a -> m (JsonResponse TransactionSubmitted)
sendRequest Int
hydraNodeId 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 = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
cardanoBobSk Tx
unsignedTx
          let signedRequest :: Value
signedRequest = Tx -> Value
forall a. ToJSON a => a -> Value
toJSON Tx
signedTx
          (Int -> Value -> IO (JsonResponse TransactionSubmitted)
forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
Int -> a -> m (JsonResponse TransactionSubmitted)
sendRequest Int
hydraNodeId 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
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} = RunningNode
node
  sendRequest :: Int -> a -> m (JsonResponse TransactionSubmitted)
sendRequest Int
hydraNodeId a
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 a
-> 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")
        (a -> ReqBodyJson a
forall a. a -> ReqBodyJson a
ReqBodyJson a
tx)
        (Proxy (JsonResponse TransactionSubmitted)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse TransactionSubmitted))
        (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
port (Int -> Option 'Http) -> Int -> Option 'Http
forall a b. (a -> b) -> a -> b
$ Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

-- | 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 -> RunningNode -> [TxId] -> IO ()
threeNodesNoErrorsOnOpen :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
threeNodesNoErrorsOnOpen Tracer IO EndToEndLog
tracer String
tmpDir node :: RunningNode
node@RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} [TxId]
hydraScriptsTxId = do
  aliceKeys :: (VerificationKey PaymentKey, SigningKey PaymentKey)
aliceKeys@(VerificationKey PaymentKey
aliceCardanoVk, 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
  bobKeys :: (VerificationKey PaymentKey, SigningKey PaymentKey)
bobKeys@(VerificationKey PaymentKey
bobCardanoVk, 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
  carolKeys :: (VerificationKey PaymentKey, SigningKey PaymentKey)
carolKeys@(VerificationKey PaymentKey
carolCardanoVk, SigningKey PaymentKey
_) <- Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
-> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
forall a. Gen a -> IO a
generate Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair

  let cardanoKeys :: [(VerificationKey PaymentKey, SigningKey PaymentKey)]
cardanoKeys = [(VerificationKey PaymentKey, SigningKey PaymentKey)
aliceKeys, (VerificationKey PaymentKey, SigningKey PaymentKey)
bobKeys, (VerificationKey PaymentKey, SigningKey PaymentKey)
carolKeys]
      hydraKeys :: [SigningKey HydraKey]
hydraKeys = [SigningKey HydraKey
aliceSk, SigningKey HydraKey
bobSk, SigningKey HydraKey
carolSk]

  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
2
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
50
  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
-> String
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, SigningKey PaymentKey)]
-> [SigningKey HydraKey]
-> [TxId]
-> ContestationPeriod
-> DepositDeadline
-> (NonEmpty HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> String
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, SigningKey PaymentKey)]
-> [SigningKey HydraKey]
-> [TxId]
-> ContestationPeriod
-> DepositDeadline
-> (NonEmpty HydraClient -> IO a)
-> IO a
withHydraCluster Tracer IO HydraNodeLog
hydraTracer String
tmpDir SocketPath
nodeSocket Int
1 [(VerificationKey PaymentKey, SigningKey PaymentKey)]
cardanoKeys [SigningKey HydraKey]
hydraKeys [TxId]
hydraScriptsTxId ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline ((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
    RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node 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)
    RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node 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)
    RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node 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" []
    IO HeadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO HeadId -> IO ())
-> ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime
-> [HydraClient] -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
10 (NonEmpty HydraClient -> [HydraClient]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty HydraClient
clients) ((Value -> Maybe HeadId) -> IO ())
-> (Value -> Maybe HeadId) -> IO ()
forall a b. (a -> b) -> a -> b
$
      Set Party -> Value -> Maybe HeadId
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob, Party
carol])

    (HydraClient -> IO ()) -> NonEmpty HydraClient -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ (\HydraClient
n -> HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node) NonEmpty HydraClient
clients

    (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
hydraNodeId :: Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId} = do
    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
10 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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" should not receive error: " String -> ShowS
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 ()

-- | 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 -> RunningNode -> [TxId] -> IO ()
initWithWrongKeys :: String -> Tracer IO EndToEndLog -> RunningNode -> [TxId] -> IO ()
initWithWrongKeys String
workDir Tracer IO EndToEndLog
tracer node :: RunningNode
node@RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} [TxId]
hydraScriptsTxId = do
  (VerificationKey PaymentKey
aliceCardanoVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Alice
  (VerificationKey PaymentKey
carolCardanoVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
Carol

  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
2
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
  ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Carol] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
  ChainConfig
bobChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline

  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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
3 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int
3, Int
4] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
4 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk] [Int
3, Int
4] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node 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
headIsInitializingWith ([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 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

-- | Open a a two participant head and incrementally commit to it.
canCommit :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
canCommit :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
canCommit Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Bob) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
30_000_000
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Bob Lovelace
30_000_000
      let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
20
      let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
      ChainConfig
aliceChainConfig <-
        HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
          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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
          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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int
2] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk] [Int
1] ((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" []
          -- _ <- waitMatch 10 n1 $ headIsInitializingWith (Set.fromList [bob])
          HeadId
headId <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
20 HydraClient
n2 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob])

          -- Commit nothing
          HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
          HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n2 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
20 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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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]

          -- 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
          UTxO' (TxOut CtxUTxO Era)
commitUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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' (TxOut CtxUTxO Era)
commitUTxO2 <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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)

          Response Tx
resp <-
            String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n2 String -> ShowS
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' (TxOut CtxUTxO Era) -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO' (TxOut CtxUTxO Era)
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 = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk Tx
depositTransaction

          RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
tx

          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
20 [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' (TxOut CtxUTxO Era) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era)
commitUTxO]
          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
20 [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 -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx)]

          HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1 IO (UTxO' (TxOut CtxUTxO Era))
-> UTxO' (TxOut CtxUTxO Era) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxO' (TxOut CtxUTxO Era)
commitUTxO

          Response Tx
resp2 <-
            String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n1 String -> ShowS
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' (TxOut CtxUTxO Era) -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO' (TxOut CtxUTxO Era)
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 depositTransaction' :: Tx
depositTransaction' = Response Tx -> Tx
forall a. Response a -> a
getResponseBody Response Tx
resp2 :: Tx
          let tx' :: Tx
tx' = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk Tx
depositTransaction'

          RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
tx'

          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
20 [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' (TxOut CtxUTxO Era) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era)
commitUTxO2]
          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
20 [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 -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx')]

          HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1 IO (UTxO' (TxOut CtxUTxO Era))
-> UTxO' (TxOut CtxUTxO Era) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxO' (TxOut CtxUTxO Era)
commitUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
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
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"
            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
20 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"

          -- Assert final wallet balance
          (UTxO' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Value)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip 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' (TxOut CtxUTxO Era)
commitUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
commitUTxO2)
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

  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

  hydraNodeBaseUrl :: HydraClient -> a
hydraNodeBaseUrl HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} = a
"http://127.0.0.1:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Int -> a
forall b a. (Show a, IsString b) => a -> b
show (Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

-- | Open a a single participant head, deposit and then recover it.
canRecoverDeposit :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
canRecoverDeposit :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
canRecoverDeposit Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node 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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Bob) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
30_000_000
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Bob Lovelace
30_000_000
      -- NOTE: this value is also used to determine the deposit deadline
      let deadline :: Natural
deadline = Natural
5
      let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
deadline
      let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
5
      ChainConfig
aliceChainConfig <-
        HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
          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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
          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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int
2] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        HeadId
headId <- Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO HeadId)
-> IO HeadId
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk] [Int
1] ((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" []
          HeadId
headId <- NominalDiffTime
-> HydraClient -> (Value -> Maybe HeadId) -> IO HeadId
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch 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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob])

          -- Commit nothing
          HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
          HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n2 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node

          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
20 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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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]

          -- stop the second node here
          HeadId -> IO HeadId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadId
headId

        -- 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' (TxOut CtxUTxO Era)
commitUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Value)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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

        Response Tx
resp <-
          String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n1 String -> ShowS
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' (TxOut CtxUTxO Era) -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO' (TxOut CtxUTxO Era)
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 = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk Tx
depositTransaction

        RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
tx

        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 -> 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 -> Lovelace
selectLovelace (Value -> Lovelace)
-> (UTxO' (TxOut CtxUTxO Era) -> Value)
-> UTxO' (TxOut CtxUTxO Era)
-> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Lovelace)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip VerificationKey PaymentKey
walletVk)
          IO Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Lovelace
0

        let path :: String
path = ByteString -> String
BSC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
urlEncode Bool
False (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TxId -> String
forall b a. (Show a, IsString b) => a -> b
show (TxBody -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody -> TxId) -> TxBody -> TxId
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx)
        -- NOTE: we need to wait for the deadline to pass before we can recover the deposit
        -- NOTE: for some reason threadDelay on MacOS behaves differently than on Linux so we need + 1 here
        DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Natural -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural
deadline Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
2 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)

        Response String
recoverResp <-
          String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"DELETE " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/commits/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path)
            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

        (Response String -> String
forall a. Response a -> a
getResponseBody Response String
recoverResp :: String) String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` String
"OK"

        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"

        (UTxO' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Value)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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
        (UTxO' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Value)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket QueryPoint
QueryTip 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' (TxOut CtxUTxO Era)
UTxOType Tx
commitUTxO
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

  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

  hydraNodeBaseUrl :: HydraClient -> a
hydraNodeBaseUrl HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} = a
"http://127.0.0.1:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Int -> a
forall b a. (Show a, IsString b) => a -> b
show (Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

-- | Make sure to be able to see pending deposits.
canSeePendingDeposits :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
canSeePendingDeposits :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
canSeePendingDeposits Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node 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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Bob) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
30_000_000
      Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Bob Lovelace
30_000_000
      let deadline :: Natural
deadline = Natural
1
      let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
deadline
      let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
1
      ChainConfig
aliceChainConfig <-
        HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
          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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
          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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int
2] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
        ()
_ <- Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk] [Int
1] ((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.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch 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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob])

          -- Commit nothing
          HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node
          HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n2 UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node

          HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
20 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
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
forall a. Monoid a => a
mempty, 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]

          -- stop the second node here
          () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- 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
        UTxO' (TxOut CtxUTxO Era)
commitUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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' (TxOut CtxUTxO Era)
commitUTxO2 <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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)
        UTxO' (TxOut CtxUTxO Era)
commitUTxO3 <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk Lovelace
3_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)

        [TxId]
deposited <- (StateT [TxId] IO [()] -> [TxId] -> IO [TxId])
-> [TxId] -> StateT [TxId] IO [()] -> IO [TxId]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [TxId] IO [()] -> [TxId] -> IO [TxId]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT [] (StateT [TxId] IO [()] -> IO [TxId])
-> StateT [TxId] IO [()] -> IO [TxId]
forall a b. (a -> b) -> a -> b
$ [UTxO' (TxOut CtxUTxO Era)]
-> (UTxO' (TxOut CtxUTxO Era) -> StateT [TxId] IO ())
-> StateT [TxId] IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UTxO' (TxOut CtxUTxO Era)
commitUTxO, UTxO' (TxOut CtxUTxO Era)
commitUTxO2, UTxO' (TxOut CtxUTxO Era)
commitUTxO3] ((UTxO' (TxOut CtxUTxO Era) -> StateT [TxId] IO ())
 -> StateT [TxId] IO [()])
-> (UTxO' (TxOut CtxUTxO Era) -> StateT [TxId] IO ())
-> StateT [TxId] IO [()]
forall a b. (a -> b) -> a -> b
$ \UTxO' (TxOut CtxUTxO Era)
utxo -> do
          Response Tx
resp <-
            String -> StateT [TxId] IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/commit")
              StateT [TxId] IO Request
-> (Request -> Request) -> StateT [TxId] IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> UTxO' (TxOut CtxUTxO Era) -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON UTxO' (TxOut CtxUTxO Era)
utxo
                StateT [TxId] IO Request
-> (Request -> StateT [TxId] IO (Response Tx))
-> StateT [TxId] IO (Response Tx)
forall a b.
StateT [TxId] IO a
-> (a -> StateT [TxId] IO b) -> StateT [TxId] IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> StateT [TxId] 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 = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk Tx
depositTransaction

          IO () -> StateT [TxId] IO ()
forall a. IO a -> StateT [TxId] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT [TxId] IO ()) -> IO () -> StateT [TxId] IO ()
forall a b. (a -> b) -> a -> b
$ RunningNode -> Tx -> IO ()
submitTx RunningNode
node Tx
tx

          IO () -> StateT [TxId] IO ()
forall a. IO a -> StateT [TxId] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT [TxId] IO ()) -> IO () -> StateT [TxId] 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"

          Response [TxId]
pendingDepositReq <-
            String -> StateT [TxId] IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"GET " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/commits")
              StateT [TxId] IO Request
-> (Request -> StateT [TxId] IO (Response [TxId]))
-> StateT [TxId] IO (Response [TxId])
forall a b.
StateT [TxId] IO a
-> (a -> StateT [TxId] IO b) -> StateT [TxId] IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> StateT [TxId] IO (Response [TxId])
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON

          let expectedResponse :: TxId
expectedResponse = TxBody -> TxId
forall era. TxBody era -> TxId
getTxId (Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
tx)
          ()
_ <- ([TxId] -> [TxId]) -> StateT [TxId] IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (TxId
expectedResponse :)
          [TxId]
expected <- StateT [TxId] IO [TxId]
forall s (m :: * -> *). MonadState s m => m s
get
          let expectedResp :: [TxId]
expectedResp = Response [TxId] -> [TxId]
forall a. Response a -> a
getResponseBody Response [TxId]
pendingDepositReq :: [TxId]
          IO () -> StateT [TxId] IO ()
forall a. IO a -> StateT [TxId] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT [TxId] IO ()) -> IO () -> StateT [TxId] IO ()
forall a b. (a -> b) -> a -> b
$ [TxId]
expectedResp [TxId] -> [TxId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [TxId]
expected

        [TxId] -> (TxId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TxId]
deposited ((TxId -> IO ()) -> IO ()) -> (TxId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TxId
deposit -> do
          let path :: String
path = ByteString -> String
BSC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
urlEncode Bool
False (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TxId -> String
forall b a. (Show a, IsString b) => a -> b
show TxId
deposit
          -- NOTE: we need to wait for the deadline to pass before we can recover the deposit
          DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Natural -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural
deadline Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
2)
          Response String
recoverResp <-
            String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"DELETE " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/commits/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path)
              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

          (Response String -> String
forall a. Response a -> a
getResponseBody Response String
recoverResp :: String) String -> String -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` String
"OK"

          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 -> 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"

        Response [TxId]
pendingDepositReq <-
          String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"GET " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HydraClient -> String
forall {a}. (Semigroup a, IsString a) => HydraClient -> a
hydraNodeBaseUrl HydraClient
n1 String -> ShowS
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

        let expectedResp :: [TxId]
expectedResp = Response [TxId] -> [TxId]
forall a. Response a -> a
getResponseBody Response [TxId]
pendingDepositReq :: [TxId]
        [TxId]
expectedResp [TxId] -> [TxId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` []
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

  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

  hydraNodeBaseUrl :: HydraClient -> a
hydraNodeBaseUrl HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} = a
"http://127.0.0.1:" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Int -> a
forall b a. (Show a, IsString b) => a -> b
show (Int
4000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

-- | Open a a single participant head with some UTxO and incrementally decommit it.
canDecommit :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
canDecommit :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
canDecommit Tracer IO EndToEndLog
tracer String
workDir RunningNode
node [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 -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Lovelace
30_000_000
    let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
    let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
        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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [] [Int
1] ((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 HydraClient
n1 ((Value -> Maybe HeadId) -> IO HeadId)
-> (Value -> Maybe HeadId) -> IO HeadId
forall a b. (a -> b) -> a -> b
$ Set Party -> Value -> Maybe HeadId
headIsInitializingWith ([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' (TxOut CtxUTxO Era)
headUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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' (TxOut CtxUTxO Era)
commitUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk 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)

      HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 (UTxO' (TxOut CtxUTxO Era)
headUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
commitUTxO) IO Tx -> (Tx -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
walletSk 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
node

      HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n1] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [Pair] -> Value
output Text
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON (UTxO' (TxOut CtxUTxO Era)
headUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
commitUTxO), 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]

      -- 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' (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO Era)
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)
-> 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
walletSk

      HydraClient -> HeadId -> Tx -> IO ()
forall {a}. ToJSON a => HydraClient -> a -> Tx -> IO ()
expectFailureOnUnsignedDecommitTx HydraClient
n1 HeadId
headId Tx
decommitTx
      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
      HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1 IO (UTxO' (TxOut CtxUTxO Era))
-> UTxO' (TxOut CtxUTxO Era) -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` UTxO' (TxOut CtxUTxO Era)
headUTxO
      (UTxO' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Value)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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
      (UTxO' (TxOut CtxUTxO Era) -> Value
UTxOType Tx -> ValueType Tx
forall tx. IsTx tx => UTxOType tx -> ValueType tx
balance (UTxO' (TxOut CtxUTxO Era) -> Value)
-> IO (UTxO' (TxOut CtxUTxO Era)) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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' (TxOut CtxUTxO Era)
decommitUTxO = Tx -> UTxO' (TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era) -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era)
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
$ RunningNode -> UTxO' (TxOut CtxUTxO Era) -> IO ()
waitForUTxO RunningNode
node UTxO' (TxOut CtxUTxO Era)
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
"DecommitFinalized" [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]

  expectFailureOnUnsignedDecommitTx :: HydraClient -> a -> Tx -> IO ()
expectFailureOnUnsignedDecommitTx HydraClient
n a
headId Tx
decommitTx = do
    let unsignedDecommitTx :: Tx
unsignedDecommitTx = [KeyWitness Era] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] (TxBody -> Tx) -> TxBody -> Tx
forall a b. (a -> b) -> a -> b
$ Tx -> TxBody
forall era. Tx era -> TxBody era
getTxBody Tx
decommitTx
    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
unsignedDecommitTx]
        , HydraClient -> Tx -> IO ()
postDecommit HydraClient
n Tx
unsignedDecommitTx
        ]

    String
validationError <- NominalDiffTime
-> HydraClient -> (Value -> Maybe String) -> IO String
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
10 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 (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
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

  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
node

-- | Can side load snapshot and resume agreement after a peer comes back online with healthy configuration
canSideLoadSnapshot :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO ()
canSideLoadSnapshot :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
canSideLoadSnapshot Tracer IO EndToEndLog
tracer String
workDir RunningNode
cardanoNode [TxId]
hydraScriptsTxId = do
  let clients :: [Actor]
clients = [Actor
Alice, Actor
Bob, Actor
Carol]
  [(VerificationKey PaymentKey
aliceCardanoVk, SigningKey PaymentKey
aliceCardanoSk), (VerificationKey PaymentKey
bobCardanoVk, SigningKey PaymentKey
_), (VerificationKey PaymentKey
carolCardanoVk, SigningKey PaymentKey
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, SigningKey PaymentKey))
-> IO [(VerificationKey PaymentKey, 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, SigningKey PaymentKey)
keysFor
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)

  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Bob, Actor
Carol] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Carol] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Carol String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice, Actor
Bob] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk, VerificationKey HydraKey
carolVk] [Int
1, Int
2, Int
3] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    UTxO' (TxOut CtxUTxO Era)
aliceUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
cardanoNode VerificationKey PaymentKey
aliceCardanoVk Lovelace
1_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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
carolVk] [Int
1, Int
2, Int
3] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      -- Carol starts its node misconfigured
      let pparamsDecorator :: Value -> Value
pparamsDecorator = Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"maxTxSize" ((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
0)
      RunOptions
wrongOptions <- HasCallStack =>
ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (Value -> Value)
-> IO RunOptions
ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
carolChainConfig String
workDir Int
3 SigningKey HydraKey
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] [Int
1, Int
2, Int
3] Value -> Value
pparamsDecorator
      Tx
tx <- Tracer IO HydraNodeLog
-> String -> Int -> RunOptions -> (HydraClient -> IO Tx) -> IO Tx
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> String -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
withPreparedHydraNode Tracer IO HydraNodeLog
hydraTracer String
workDir Int
3 RunOptions
wrongOptions ((HydraClient -> IO Tx) -> IO Tx)
-> (HydraClient -> IO Tx) -> IO Tx
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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob, Party
carol])

        -- Alice commits something
        HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode

        -- Everyone else commits nothing
        (HydraClient -> IO ()) -> [HydraClient] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ (\HydraClient
n -> HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n UTxO' (TxOut CtxUTxO Era)
forall a. Monoid a => a
mempty 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode) [HydraClient
n2, HydraClient
n3]

        -- Observe open with the relevant UTxOs
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient
n1, HydraClient
n2, HydraClient
n3] (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON UTxO' (TxOut CtxUTxO Era)
aliceUTxO, 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]

        -- Alice submits a new transaction
        UTxO' (TxOut CtxUTxO Era)
utxo <- HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1
        Tx
tx <- NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
testNetworkId UTxO' (TxOut CtxUTxO Era)
utxo 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]

        -- Alice and Bob accept it
        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
"TxValid"
          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
"transactionId" 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
$ Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx)

        -- Carol does not because of its node being missconfigured
        NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
3 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
"TxInvalid"
          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
"transaction" 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
"txId" 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
$ Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx)

        -- We observe that a snapshot is in progress, but Carol has not signed it.
        SeenSnapshot Tx
seenSn1 <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n1
        SeenSnapshot Tx
seenSn2 <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n2
        SeenSnapshot Tx
seenSn1 SeenSnapshot Tx -> SeenSnapshot Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SeenSnapshot Tx
seenSn2
        SeenSnapshot Tx
seenSn3 <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n3
        SeenSnapshot Tx
seenSn2 SeenSnapshot Tx -> SeenSnapshot Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldNotBe` SeenSnapshot Tx
seenSn3

        Tx -> IO Tx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
tx

      -- 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
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"

      -- Carol reconnects with healthy reconfigured node
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
carolChainConfig String
workDir Int
3 SigningKey HydraKey
carolSk [VerificationKey HydraKey
aliceVk, VerificationKey HydraKey
bobVk] [Int
1, Int
2, Int
3] ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n3 -> do
        -- Carol re-submits the same transaction
        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]
        -- Carol accepts it
        NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
3 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
"TxValid"
          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
"transactionId" 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
$ Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx)
        -- But now Alice and Bob does not because they already applied it
        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
"TxInvalid"
          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
"transaction" 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
"txId" 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
$ Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId Tx
tx)

        -- \| Up to this point the head became stuck and no further SnapshotConfirmed
        -- including above tx will be seen signed by everyone.
        -- We observe that a snapshot is in progress, but Carol has not signed it.
        SeenSnapshot Tx
seenSn1 <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n1
        SeenSnapshot Tx
seenSn2 <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n2
        SeenSnapshot Tx
seenSn1 SeenSnapshot Tx -> SeenSnapshot Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SeenSnapshot Tx
seenSn2
        SeenSnapshot Tx
seenSn3 <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n3
        SeenSnapshot Tx
seenSn2 SeenSnapshot Tx -> SeenSnapshot Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldNotBe` SeenSnapshot Tx
seenSn3

        -- The party side-loads latest confirmed snapshot (which is the initial)
        -- This also prunes local txs, and discards any signing round inflight
        ConfirmedSnapshot Tx
snapshotConfirmed <- HydraClient -> IO (ConfirmedSnapshot Tx)
getSnapshotConfirmed HydraClient
n1
        ((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 -> do
          HydraClient -> Value -> IO ()
send HydraClient
n (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
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
"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
0 :: Integer))

        -- Carol re-submits the same transaction (but anyone can at this point)
        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 it
        -- Note: We can't use `waitForAllMatch` 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
1 :: 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

        -- Finally observe everyone having the same latest seen snapshot.
        SeenSnapshot Tx
seenSn1' <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n1
        SeenSnapshot Tx
seenSn2' <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n2
        SeenSnapshot Tx
seenSn1' SeenSnapshot Tx -> SeenSnapshot Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SeenSnapshot Tx
seenSn2'
        SeenSnapshot Tx
seenSn3' <- HydraClient -> IO (SeenSnapshot Tx)
getSnapshotLastSeen HydraClient
n3
        SeenSnapshot Tx
seenSn2' SeenSnapshot Tx -> SeenSnapshot Tx -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` SeenSnapshot Tx
seenSn3'
 where
  RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} = RunningNode
cardanoNode
  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 -> RunningNode -> [TxId] -> IO ()
threeNodesWithMirrorParty :: Tracer IO EndToEndLog -> String -> RunningNode -> [TxId] -> IO ()
threeNodesWithMirrorParty Tracer IO EndToEndLog
tracer String
workDir cardanoNode :: RunningNode
cardanoNode@RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> NominalDiffTime
blockTime :: NominalDiffTime
blockTime} [TxId]
hydraScriptsTxId = do
  let parties :: [Actor]
parties = [Actor
Alice, Actor
Bob]

  [(VerificationKey PaymentKey
aliceCardanoVk, SigningKey PaymentKey
aliceCardanoSk), (VerificationKey PaymentKey
bobCardanoVk, SigningKey PaymentKey
_)] <- [Actor]
-> (Actor
    -> IO (VerificationKey PaymentKey, SigningKey PaymentKey))
-> IO [(VerificationKey PaymentKey, 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, SigningKey PaymentKey)
keysFor
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)
  RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode 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)

  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
  let depositDeadline :: DepositDeadline
depositDeadline = Natural -> DepositDeadline
UnsafeDepositDeadline Natural
200

  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> [TxId]
-> [Actor]
-> ContestationPeriod
-> DepositDeadline
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket [TxId]
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod DepositDeadline
depositDeadline
      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
  let allNodeIds :: [Int]
allNodeIds = [Int
1, Int
2, Int
3]
  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
1 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int]
allNodeIds ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n1 -> do
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
bobChainConfig String
workDir Int
2 SigningKey HydraKey
bobSk [VerificationKey HydraKey
aliceVk] [Int]
allNodeIds ((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
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfig String
workDir Int
3 SigningKey HydraKey
aliceSk [VerificationKey HydraKey
bobVk] [Int]
allNodeIds ((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
headIsInitializingWith ([Party] -> Set Party
forall a. Ord a => [a] -> Set a
Set.fromList [Party
alice, Party
bob])

        -- N1 & N3 commit the same thing at the same time
        -- XXX: one will fail but the head will still open
        UTxO' (TxOut CtxUTxO Era)
aliceUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
cardanoNode VerificationKey PaymentKey
aliceCardanoVk Lovelace
1_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)
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
race_
          (HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n1 UTxO' (TxOut CtxUTxO Era)
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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode)
          (HydraClient -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n3 UTxO' (TxOut CtxUTxO Era)
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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode)

        -- N2 commits something
        UTxO' (TxOut CtxUTxO Era)
bobUTxO <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
cardanoNode VerificationKey PaymentKey
bobCardanoVk Lovelace
1_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 -> UTxO' (TxOut CtxUTxO Era) -> IO Tx
requestCommitTx HydraClient
n2 UTxO' (TxOut CtxUTxO Era)
bobUTxO 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
>>= RunningNode -> Tx -> IO ()
submitTx RunningNode
cardanoNode

        -- Observe open with relevant UTxO
        HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
hydraTracer (NominalDiffTime
20 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
blockTime) [HydraClient]
clients (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> [Pair] -> Value
output Text
"HeadIsOpen" [Key
"utxo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTxO' (TxOut CtxUTxO Era) -> Value
forall a. ToJSON a => a -> Value
toJSON (UTxO' (TxOut CtxUTxO Era)
aliceUTxO UTxO' (TxOut CtxUTxO Era)
-> UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era)
forall a. Semigroup a => a -> a -> a
<> UTxO' (TxOut CtxUTxO Era)
bobUTxO), 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]

        -- N3 performs a simple transaction from N3 to itself
        UTxO' (TxOut CtxUTxO Era)
utxo <- HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n3
        Tx
tx <- NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO' (TxOut CtxUTxO Era)
utxo 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 it
        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"
          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
1 :: Integer))

      -- \| 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' (TxOut CtxUTxO Era)
utxo <- HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
n1
      Tx
tx <- NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
networkId UTxO' (TxOut CtxUTxO Era)
utxo 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
      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"
        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))

-- * L2 scenarios

-- | Finds UTxO owned by given key in the head and creates transactions
-- respending it to the same address as fast as possible, forever.
-- NOTE: This relies on zero-fee protocol parameters.
respendUTxO :: HydraClient -> SigningKey PaymentKey -> NominalDiffTime -> IO ()
respendUTxO :: HydraClient -> SigningKey PaymentKey -> NominalDiffTime -> IO ()
respendUTxO HydraClient
client SigningKey PaymentKey
sk NominalDiffTime
delay = do
  UTxO' (TxOut CtxUTxO Era)
utxo <- HydraClient -> IO (UTxO' (TxOut CtxUTxO Era))
getSnapshotUTxO HydraClient
client
  IO Any -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO Era) -> IO Any
respend UTxO' (TxOut CtxUTxO Era)
utxo
 where
  vk :: VerificationKey PaymentKey
vk = SigningKey PaymentKey -> VerificationKey PaymentKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey PaymentKey
sk

  respend :: UTxO' (TxOut CtxUTxO Era) -> IO Any
respend UTxO' (TxOut CtxUTxO Era)
utxo = do
    Tx
tx <- NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> IO Tx
forall (m :: * -> *).
MonadFail m =>
NetworkId
-> UTxO' (TxOut CtxUTxO Era)
-> SigningKey PaymentKey
-> VerificationKey PaymentKey
-> m Tx
mkTransferTx NetworkId
testNetworkId UTxO' (TxOut CtxUTxO Era)
utxo SigningKey PaymentKey
sk VerificationKey PaymentKey
vk
    UTxO' (TxOut CtxUTxO Era)
utxo' <- Tx -> IO (UTxO' (TxOut CtxUTxO Era))
submitToHead (SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
signTx SigningKey PaymentKey
sk Tx
tx)
    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 NominalDiffTime
delay
    UTxO' (TxOut CtxUTxO Era) -> IO Any
respend UTxO' (TxOut CtxUTxO Era)
utxo'

  submitToHead :: Tx -> IO (UTxO' (TxOut CtxUTxO Era))
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' (TxOut CtxUTxO Era)))
-> IO (UTxO' (TxOut CtxUTxO Era))
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
10 HydraClient
client ((Value -> Maybe (UTxO' (TxOut CtxUTxO Era)))
 -> IO (UTxO' (TxOut CtxUTxO Era)))
-> (Value -> Maybe (UTxO' (TxOut CtxUTxO Era)))
-> IO (UTxO' (TxOut CtxUTxO Era))
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' (TxOut CtxUTxO Era)))
-> Maybe (UTxO' (TxOut CtxUTxO Era))
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' (TxOut CtxUTxO Era)))
-> Value -> Maybe (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (UTxO' (TxOut CtxUTxO Era))
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 ->
  RunningNode ->
  Actor ->
  Coin ->
  IO ()
refuelIfNeeded :: Tracer IO EndToEndLog -> RunningNode -> Actor -> Lovelace -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
actor Lovelace
amount = do
  (VerificationKey PaymentKey
actorVk, SigningKey PaymentKey
_) <- Actor -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor Actor
actor
  UTxO' (TxOut CtxUTxO Era)
existingUtxo <- NetworkId
-> SocketPath
-> QueryPoint
-> VerificationKey PaymentKey
-> IO (UTxO' (TxOut CtxUTxO Era))
queryUTxOFor NetworkId
networkId SocketPath
nodeSocket 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' (TxOut CtxUTxO Era)
utxo = UTxO' (TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era)
utxo <- RunningNode
-> VerificationKey PaymentKey
-> Lovelace
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
actorVk 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' (TxOut CtxUTxO Era)
$sel:utxo:ClusterOptions :: UTxO' (TxOut CtxUTxO Era)
utxo :: UTxO' (TxOut CtxUTxO Era)
utxo}
 where
  RunningNode{NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId, SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket} = RunningNode
node

-- | Return the remaining funds to the faucet
returnFundsToFaucet ::
  Tracer IO EndToEndLog ->
  RunningNode ->
  Actor ->
  IO ()
returnFundsToFaucet :: Tracer IO EndToEndLog -> RunningNode -> Actor -> IO ()
returnFundsToFaucet Tracer IO EndToEndLog
tracer =
  Tracer IO FaucetLog -> RunningNode -> 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)

headIsInitializingWith :: Set Party -> Value -> Maybe HeadId
headIsInitializingWith :: Set Party -> Value -> Maybe HeadId
headIsInitializingWith 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
"HeadIsInitializing"
  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

checkFanout :: HeadId -> UTxO -> Value -> Maybe ()
checkFanout :: HeadId -> UTxO' (TxOut CtxUTxO Era) -> Value -> Maybe ()
checkFanout HeadId
expectedHeadId UTxO' (TxOut CtxUTxO Era)
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' (TxOut CtxUTxO Era)
utxo <- 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
"utxo" Maybe Value
-> (Value -> Maybe (UTxO' (TxOut CtxUTxO Era)))
-> Maybe (UTxO' (TxOut CtxUTxO Era))
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' (TxOut CtxUTxO Era)))
-> Value -> Maybe (UTxO' (TxOut CtxUTxO Era))
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser (UTxO' (TxOut CtxUTxO Era))
forall a. FromJSON a => Value -> Parser a
parseJSON
  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 (UTxO' (TxOut CtxUTxO Era) -> UTxO' (TxOut CtxUTxO Era) -> Bool
forall out. Eq out => UTxO' out -> UTxO' out -> Bool
UTxO.containsOutputs UTxO' (TxOut CtxUTxO Era)
utxo UTxO' (TxOut CtxUTxO Era)
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