{-# 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 CardanoClient (
  QueryPoint (QueryTip),
  RunningNode (..),
  buildTransaction,
  queryTip,
  queryUTxOFor,
  submitTx,
 )
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 (key, values, _JSON)
import Data.Aeson.Types (parseMaybe)
import Data.ByteString (isInfixOf)
import Data.ByteString qualified as B
import Data.Set qualified as Set
import Hydra.API.HTTPServer (DraftCommitTxResponse (..), TransactionSubmitted (..))
import Hydra.Cardano.Api (Coin (..), File (File), Key (SigningKey), PaymentKey, Tx, TxId, UTxO, getVerificationKey, isVkTxOut, lovelaceToValue, makeSignedTransaction, mkVkAddress, selectLovelace, signTx, txOutAddress, txOutValue, writeFileTextEnvelope, pattern ReferenceScriptNone, pattern TxOut, pattern TxOutDatumNone)
import Hydra.Chain.Direct.Tx (verificationKeyToOnChainId)
import Hydra.Cluster.Faucet (FaucetLog, seedFromFaucet, seedFromFaucet_)
import Hydra.Cluster.Faucet qualified as Faucet
import Hydra.Cluster.Fixture (Actor (..), actorName, alice, aliceSk, aliceVk, bob, bobSk, bobVk, carol, carolSk)
import Hydra.Cluster.Mithril (MithrilLog)
import Hydra.Cluster.Options (Options)
import Hydra.Cluster.Util (chainConfigFor, keysFor, modifyConfig, setNetworkId)
import Hydra.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod), fromNominalDiffTime)
import Hydra.HeadId (HeadId)
import Hydra.Ledger (IsTx (balance), txId)
import Hydra.Ledger.Cardano (genKeyPair, mkSimpleTx)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Options (networkId, startChainFrom)
import Hydra.Party (Party)
import HydraNode (
  HydraClient (..),
  HydraNodeLog,
  getSnapshotUTxO,
  input,
  output,
  requestCommitTx,
  send,
  waitFor,
  waitForAllMatch,
  waitForNodesConnected,
  waitMatch,
  withHydraCluster,
  withHydraNode,
 )
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 System.Directory (removeDirectoryRecursive)
import System.FilePath ((</>))
import Test.QuickCheck (choose, 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 -> Coin
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, Maybe EndToEndLog
Value -> Parser [EndToEndLog]
Value -> Parser EndToEndLog
(Value -> Parser EndToEndLog)
-> (Value -> Parser [EndToEndLog])
-> Maybe EndToEndLog
-> FromJSON EndToEndLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser EndToEndLog
parseJSON :: Value -> Parser EndToEndLog
$cparseJSONList :: Value -> Parser [EndToEndLog]
parseJSONList :: Value -> Parser [EndToEndLog]
$comittedField :: Maybe EndToEndLog
omittedField :: Maybe EndToEndLog
FromJSON)

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
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode VerificationKey PaymentKey
aliceCardanoVk Coin
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
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
cardanoNode VerificationKey PaymentKey
bobCardanoVk Coin
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
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod
      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
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod
      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.
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.
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.
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
nodeSocket :: SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket, NetworkId
networkId :: NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId} = RunningNode
cardanoNode

testPreventResumeReconfiguredPeer :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> TxId -> IO ()
testPreventResumeReconfiguredPeer :: Tracer IO EndToEndLog -> String -> RunningNode -> TxId -> IO ()
testPreventResumeReconfiguredPeer Tracer IO EndToEndLog
tracer String
workDir RunningNode
cardanoNode TxId
hydraScriptsTxId = do
  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
1
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [Actor
Bob] ContestationPeriod
contestationPeriod
      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
aliceChainConfigWithoutBob <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] ContestationPeriod
contestationPeriod
      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
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [Actor
Alice] ContestationPeriod
contestationPeriod
      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
      aliceStartsWithoutKnowingBob :: (HydraClient -> IO ()) -> IO ()
aliceStartsWithoutKnowingBob =
        Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
hydraTracer ChainConfig
aliceChainConfigWithoutBob String
workDir Int
2 SigningKey HydraKey
aliceSk [] [Int
1, Int
2]
      aliceRestartsWithBobConfigured :: (HydraClient -> IO ()) -> IO ()
aliceRestartsWithBobConfigured =
        Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
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]

  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
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
    (HydraClient -> IO ()) -> IO ()
aliceStartsWithoutKnowingBob ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      Tracer IO HydraNodeLog -> [HydraClient] -> IO ()
failToConnect Tracer IO HydraNodeLog
hydraTracer [HydraClient
n1, HydraClient
n2]

    DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1

    (HydraClient -> IO ()) -> IO ()
aliceRestartsWithBobConfigured (IO () -> HydraClient -> IO ()
forall a b. a -> b -> a
const (IO () -> HydraClient -> IO ()) -> IO () -> HydraClient -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1)
      IO () -> Selector HUnitFailure -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` Selector HUnitFailure
aFailure

    DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1

    String -> IO ()
removeDirectoryRecursive (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
workDir String -> ShowS
</> String
"state-2"

    (HydraClient -> IO ()) -> IO ()
aliceRestartsWithBobConfigured ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
n2 -> do
      HasCallStack =>
Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
10 [HydraClient
n1, HydraClient
n2]
 where
  RunningNode{SocketPath
$sel:nodeSocket:RunningNode :: RunningNode -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NetworkId
$sel:networkId:RunningNode :: RunningNode -> NetworkId
networkId :: NetworkId
networkId} = RunningNode
cardanoNode

  aFailure :: Selector HUnitFailure
  aFailure :: Selector HUnitFailure
aFailure = Bool -> Selector HUnitFailure
forall a b. a -> b -> a
const Bool
True

  failToConnect :: Tracer IO HydraNodeLog -> [HydraClient] -> IO ()
failToConnect Tracer IO HydraNodeLog
tr [HydraClient]
nodes = HasCallStack =>
Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
tr NominalDiffTime
10 [HydraClient]
nodes IO () -> Selector SomeException -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` Selector SomeException
anyException

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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
cardanoNode Actor
Alice Coin
100_000_000
  let contestationPeriod :: ContestationPeriod
contestationPeriod = Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
2
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] ContestationPeriod
contestationPeriod
      -- 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.
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.
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
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])
    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
10 [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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Coin
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
      ChainConfig
aliceChainConfig <-
        HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] ContestationPeriod
contestationPeriod
          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.
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
        Coin
amount <- Integer -> Coin
Coin (Integer -> Coin) -> IO Integer -> IO Coin
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
-> Coin
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk Coin
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" []
        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
"HeadIsFinalized" [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]
      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
blockTime :: NominalDiffTime
$sel:blockTime:RunningNode :: RunningNode -> 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 -> IO ()) ->
  IO ()
singlePartyOpenAHead :: Tracer IO EndToEndLog
-> String
-> RunningNode
-> TxId
-> (HydraClient -> SigningKey PaymentKey -> IO ())
-> IO ()
singlePartyOpenAHead Tracer IO EndToEndLog
tracer String
workDir RunningNode
node TxId
hydraScriptsTxId HydraClient -> SigningKey PaymentKey -> IO ()
callback =
  (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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Coin
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
    ChainConfig
aliceChainConfig <-
      HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] ContestationPeriod
contestationPeriod
        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
-> Coin
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk Coin
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 ())
-> IO ()
forall a.
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)
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 -> IO ()
callback HydraClient
n1 SigningKey PaymentKey
walletSk
 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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Coin
25_000_000
      ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] (ContestationPeriod -> IO ChainConfig)
-> ContestationPeriod -> IO ChainConfig
forall a b. (a -> b) -> a -> b
$ Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
      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.
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
-> Coin
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
walletVk Coin
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)
        -- Commit the script output
        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

-- | 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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Coin
20_000_000
    ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] (ContestationPeriod -> IO ChainConfig)
-> ContestationPeriod -> IO ChainConfig
forall a b. (a -> b) -> a -> b
$ Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
    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.
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
-> Coin
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
someExternalVk Coin
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
-> Coin
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
someExternalVk Coin
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
someOutput =
            AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
              AddressInEra Era
someAddress
              (Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
2_000_000)
              TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
              ReferenceScript
ReferenceScriptNone
      NetworkId
-> SocketPath
-> AddressInEra Era
-> UTxO' (TxOut CtxUTxO Era)
-> [TxIn]
-> [TxOut CtxTx]
-> IO (Either (TxBodyErrorAutoBalance Era) TxBody)
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
someOutput] IO (Either (TxBodyErrorAutoBalance Era) TxBody)
-> (Either (TxBodyErrorAutoBalance Era) TxBody -> 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 TxBody
body -> do
          let unsignedTx :: Tx
unsignedTx = [KeyWitness Era] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody
body
          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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Coin
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)
  ChainConfig
aliceChainConfig <-
    HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] ContestationPeriod
oneWeek
      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.
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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
Alice Coin
25_000_000
    ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [] (ContestationPeriod -> IO ChainConfig)
-> ContestationPeriod -> IO ChainConfig
forall a b. (a -> b) -> a -> b
$ Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
100
    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.
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
-> Coin
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
cardanoBobVk Coin
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
carolsOutput =
            AddressInEra Era
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra Era
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
              AddressInEra Era
carolsAddress
              (Coin -> Value
lovelaceToValue (Coin -> Value) -> Coin -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
2_000_000)
              TxOutDatum CtxTx
forall ctx. TxOutDatum ctx
TxOutDatumNone
              ReferenceScript
ReferenceScriptNone
      -- prepare fully balanced tx body
      NetworkId
-> SocketPath
-> AddressInEra Era
-> UTxO' (TxOut CtxUTxO Era)
-> [TxIn]
-> [TxOut CtxTx]
-> IO (Either (TxBodyErrorAutoBalance Era) TxBody)
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
carolsOutput] IO (Either (TxBodyErrorAutoBalance Era) TxBody)
-> (Either (TxBodyErrorAutoBalance Era) TxBody -> 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 TxBody
body -> do
          let unsignedTx :: Tx
unsignedTx = [KeyWitness Era] -> TxBody -> Tx
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody
body
          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 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
-> (NonEmpty HydraClient -> IO ())
-> IO ()
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> String
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, SigningKey PaymentKey)]
-> [SigningKey HydraKey]
-> TxId
-> ContestationPeriod
-> (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 ((NonEmpty HydraClient -> IO ()) -> IO ())
-> (NonEmpty HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(HydraClient
leader :| [HydraClient]
rest) -> do
    let clients :: [HydraClient]
clients = HydraClient
leader HydraClient -> [HydraClient] -> [HydraClient]
forall a. a -> [a] -> [a]
: [HydraClient]
rest
    HasCallStack =>
Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
hydraTracer NominalDiffTime
20 [HydraClient]
clients

    -- Funds to be used as fuel by Hydra protocol transactions
    RunningNode
-> VerificationKey PaymentKey
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node VerificationKey PaymentKey
aliceCardanoVk Coin
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
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node VerificationKey PaymentKey
bobCardanoVk Coin
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
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node VerificationKey PaymentKey
carolCardanoVk Coin
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 [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 ()) -> [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) [HydraClient]
clients

    (HydraClient -> IO ()) -> [HydraClient] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ HydraClient -> IO ()
shouldNotReceivePostTxError [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

  ChainConfig
aliceChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Alice String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [Actor
Carol] (Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
2)
  ChainConfig
bobChainConfig <- HasCallStack =>
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
Actor
-> String
-> SocketPath
-> TxId
-> [Actor]
-> ContestationPeriod
-> IO ChainConfig
chainConfigFor Actor
Bob String
workDir SocketPath
nodeSocket TxId
hydraScriptsTxId [Actor
Alice] (Natural -> ContestationPeriod
UnsafeContestationPeriod Natural
2)

  let hydraTracer :: Tracer IO HydraNodeLog
hydraTracer = (HydraNodeLog -> EndToEndLog)
-> Tracer IO EndToEndLog -> Tracer IO HydraNodeLog
forall a' a. (a' -> a) -> Tracer IO a -> Tracer IO a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap HydraNodeLog -> EndToEndLog
FromHydraNode Tracer IO EndToEndLog
tracer
  Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO ())
-> IO ()
forall a.
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.
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
-> Coin
-> Tracer IO FaucetLog
-> IO ()
seedFromFaucet_ RunningNode
node VerificationKey PaymentKey
aliceCardanoVk Coin
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

-- * 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 =
    case (TxOut CtxUTxO Era -> Bool)
-> UTxO' (TxOut CtxUTxO Era) -> Maybe (TxIn, TxOut CtxUTxO Era)
forall out. (out -> Bool) -> UTxO' out -> Maybe (TxIn, out)
UTxO.find (VerificationKey PaymentKey -> TxOut CtxUTxO Era -> Bool
forall ctx era. VerificationKey PaymentKey -> TxOut ctx era -> Bool
isVkTxOut VerificationKey PaymentKey
vk) UTxO' (TxOut CtxUTxO Era)
utxo of
      Maybe (TxIn, TxOut CtxUTxO Era)
Nothing -> String -> IO Any
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no utxo left to spend"
      Just (TxIn
txIn, TxOut CtxUTxO Era
txOut) ->
        case (TxIn, TxOut CtxUTxO Era)
-> (AddressInEra Era, Value)
-> SigningKey PaymentKey
-> Either TxBodyError Tx
mkSimpleTx (TxIn
txIn, TxOut CtxUTxO Era
txOut) (TxOut CtxUTxO Era -> AddressInEra Era
forall ctx. TxOut ctx -> AddressInEra Era
txOutAddress TxOut CtxUTxO Era
txOut, TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO Era
txOut) SigningKey PaymentKey
sk of
          Left TxBodyError
err ->
            String -> IO Any
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Any) -> String -> IO Any
forall a b. (a -> b) -> a -> b
$ String
"mkSimpleTx failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> String
forall b a. (Show a, IsString b) => a -> b
show TxBodyError
err
          Right Tx
tx -> do
            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
$
        TxId -> Value
forall a. ToJSON a => a -> Value
toJSON (Tx -> TxIdType Tx
forall tx. IsTx tx => tx -> TxIdType tx
txId 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
"confirmedTransactions" 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 -> Coin -> IO ()
refuelIfNeeded Tracer IO EndToEndLog
tracer RunningNode
node Actor
actor Coin
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 :: Coin
currentBalance = Value -> Coin
selectLovelace (Value -> Coin) -> Value -> Coin
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 (Coin
currentBalance Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
amount) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    UTxO' (TxOut CtxUTxO Era)
utxo <- RunningNode
-> VerificationKey PaymentKey
-> Coin
-> Tracer IO FaucetLog
-> IO (UTxO' (TxOut CtxUTxO Era))
seedFromFaucet RunningNode
node VerificationKey PaymentKey
actorVk Coin
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 :: Coin
refuelingAmount = Coin
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

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