{-# LANGUAGE DuplicateRecordFields #-}

module HydraNode where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (delete)

import Cardano.BM.Tracing (ToObject)
import CardanoNode (cliQueryProtocolParameters)
import Control.Concurrent.Async (forConcurrently_)
import Control.Concurrent.Class.MonadSTM (modifyTVar', newTVarIO, readTVarIO)
import Control.Exception (Handler (..), IOException, catches)
import Control.Lens ((?~))
import Control.Monad.Class.MonadAsync (forConcurrently)
import Data.Aeson (Value (..), object, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Lens (atKey, key)
import Data.Aeson.Types (Pair)
import Data.List qualified as List
import Data.Text (pack)
import Data.Text qualified as T
import Hydra.API.HTTPServer (DraftCommitTxRequest (..), DraftCommitTxResponse (..))
import Hydra.Cluster.Util (readConfigFile)
import Hydra.Logging (Tracer, Verbosity (..), traceWith)
import Hydra.Network (Host (Host), NodeId (NodeId))
import Hydra.Network qualified as Network
import Hydra.Options (ChainConfig (..), DirectChainConfig (..), LedgerConfig (..), RunOptions (..), defaultDirectChainConfig, toArgs)
import Hydra.Tx.ContestationPeriod (ContestationPeriod)
import Hydra.Tx.Crypto (HydraKey)
import Network.HTTP.Conduit (parseUrlThrow)
import Network.HTTP.Req (GET (..), HttpException, JsonResponse, NoReqBody (..), POST (..), ReqBodyJson (..), defaultHttpConfig, responseBody, runReq, (/:))
import Network.HTTP.Req qualified as Req
import Network.HTTP.Simple (httpLbs, setRequestBodyJSON)
import Network.WebSockets (Connection, ConnectionException, HandshakeException, receiveData, runClient, sendClose, sendTextData)
import System.FilePath ((<.>), (</>))
import System.IO.Temp (withSystemTempDirectory)
import System.Info (os)
import System.Process (
  CreateProcess (..),
  ProcessHandle,
  StdStream (..),
  proc,
  withCreateProcess,
 )
import Test.Hydra.Prelude (checkProcessHasNotDied, failAfter, failure, shouldNotBe, withLogFile)
import Prelude qualified

data HydraClient = HydraClient
  { HydraClient -> Int
hydraNodeId :: Int
  , HydraClient -> Host
apiHost :: Host
  , HydraClient -> Connection
connection :: Connection
  , HydraClient -> Tracer IO HydraNodeLog
tracer :: Tracer IO HydraNodeLog
  }

-- | Create an input as expected by 'send'.
input :: Text -> [Pair] -> Aeson.Value
input :: Text -> [Pair] -> Value
input Text
tag [Pair]
pairs = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tag) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
pairs

send :: HydraClient -> Aeson.Value -> IO ()
send :: HydraClient -> Value -> IO ()
send HydraClient{Tracer IO HydraNodeLog
$sel:tracer:HydraClient :: HydraClient -> Tracer IO HydraNodeLog
tracer :: Tracer IO HydraNodeLog
tracer, Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId, Connection
$sel:connection:HydraClient :: HydraClient -> Connection
connection :: Connection
connection} Value
v = do
  Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
connection (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v)
  Tracer IO HydraNodeLog -> HydraNodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HydraNodeLog
tracer (HydraNodeLog -> IO ()) -> HydraNodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Value -> HydraNodeLog
SentMessage Int
hydraNodeId Value
v

waitNext :: HasCallStack => HydraClient -> IO Aeson.Value
waitNext :: HasCallStack => HydraClient -> IO Value
waitNext HydraClient{Connection
$sel:connection:HydraClient :: HydraClient -> Connection
connection :: Connection
connection} = do
  -- NOTE: We delay on connection errors to give other assertions the chance to
  -- provide more detail (e.g. checkProcessHasNotDied) before this fails.
  ByteString
bytes <-
    IO ByteString -> IO (Either ConnectionException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
connection) IO (Either ConnectionException ByteString)
-> (Either ConnectionException ByteString -> IO ByteString)
-> IO ByteString
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 (ConnectionException
err :: ConnectionException) -> do
        DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
        String -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
"waitNext: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ConnectionException -> String
forall b a. (Show a, IsString b) => a -> b
show ConnectionException
err
      Right ByteString
msg -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
msg
  case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode' ByteString
bytes of
    Left String
err -> String -> IO Value
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO Value) -> String -> IO Value
forall a b. (a -> b) -> a -> b
$ String
"WaitNext failed to decode msg: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
    Right Value
value -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value

-- | Create an output as expected by 'waitFor' and 'waitForAll'.
output :: Text -> [Pair] -> Aeson.Value
output :: Text -> [Pair] -> Value
output Text
tag [Pair]
pairs = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tag) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
pairs

-- | Wait some time for a single API server output from each of given nodes.
-- This function waits for @delay@ seconds for message @expected@  to be seen by all
-- given @nodes@.
waitFor :: HasCallStack => Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> Aeson.Value -> IO ()
waitFor :: HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
tracer NominalDiffTime
delay [HydraClient]
nodes Value
v = HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> [Value] -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> [Value] -> IO ()
waitForAll Tracer IO HydraNodeLog
tracer NominalDiffTime
delay [HydraClient]
nodes [Value
v]

-- | Wait up to some time for an API server output to match the given predicate.
waitMatch :: HasCallStack => NominalDiffTime -> HydraClient -> (Aeson.Value -> Maybe a) -> IO a
waitMatch :: forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
delay client :: HydraClient
client@HydraClient{Tracer IO HydraNodeLog
$sel:tracer:HydraClient :: HydraClient -> Tracer IO HydraNodeLog
tracer :: Tracer IO HydraNodeLog
tracer, Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} Value -> Maybe a
match = do
  TVar [Value]
seenMsgs <- [Value] -> IO (TVar IO [Value])
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
  DiffTime -> IO a -> IO (Maybe a)
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout (NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
delay) (TVar [Value] -> IO a
go TVar [Value]
seenMsgs) IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just a
x -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    Maybe a
Nothing -> do
      [Value]
msgs <- TVar IO [Value] -> IO [Value]
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar [Value]
TVar IO [Value]
seenMsgs
      String -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$
        Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
            [ Text
"waitMatch did not match a message within " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
forall b a. (Show a, IsString b) => a -> b
show NominalDiffTime
delay
            , Char -> Int -> Text -> Text
padRight Char
' ' Int
20 Text
"  nodeId:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId
            , Char -> Int -> Text -> Text
padRight Char
' ' Int
20 Text
"  seen messages:"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (Int -> [Text] -> [Text]
align Int
20 (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> Text) -> [Value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
msgs))
            ]
 where
  go :: TVar [Value] -> IO a
go TVar [Value]
seenMsgs = do
    Value
msg <- HasCallStack => HydraClient -> IO Value
HydraClient -> IO Value
waitNext HydraClient
client
    Tracer IO HydraNodeLog -> HydraNodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HydraNodeLog
tracer (Int -> Value -> HydraNodeLog
ReceivedMessage Int
hydraNodeId Value
msg)
    STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar IO [Value] -> ([Value] -> [Value]) -> STM IO ()
forall a. TVar IO a -> (a -> a) -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar' TVar [Value]
TVar IO [Value]
seenMsgs (Value
msg :))
    IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TVar [Value] -> IO a
go TVar [Value]
seenMsgs) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe a
match Value
msg)

  align :: Int -> [Text] -> [Text]
align Int
_ [] = []
  align Int
n (Text
h : [Text]
q) = Text
h Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
T.replicate Int
n Text
" " <>) [Text]
q

-- | Wait up to some `delay` for some JSON `Value` to match given function.
--
-- This is a generalisation of `waitMatch` to multiple nodes.
waitForAllMatch :: (Eq a, Show a, HasCallStack) => NominalDiffTime -> [HydraClient] -> (Aeson.Value -> Maybe a) -> IO a
waitForAllMatch :: forall a.
(Eq a, Show a, HasCallStack) =>
NominalDiffTime -> [HydraClient] -> (Value -> Maybe a) -> IO a
waitForAllMatch NominalDiffTime
delay [HydraClient]
nodes Value -> Maybe a
match = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([HydraClient] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HydraClient]
nodes) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"no clients to wait for"
  [a]
results <- [HydraClient] -> (HydraClient -> IO a) -> IO [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadAsync m) =>
t a -> (a -> m b) -> m (t b)
forConcurrently [HydraClient]
nodes ((HydraClient -> IO a) -> IO [a])
-> (HydraClient -> IO a) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \HydraClient
n -> NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
delay HydraClient
n Value -> Maybe a
match
  case [a]
results of
    [] -> String -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"empty results, but " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show ([HydraClient] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HydraClient]
nodes) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" clients"
    (a
r : [a]
rs) -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r) [a]
rs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"inconsistent results: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [a] -> String
forall b a. (Show a, IsString b) => a -> b
show [a]
results
      a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r

-- | Wait some time for a list of outputs from each of given nodes.
-- This function is the generalised version of 'waitFor', allowing several messages
-- to be waited for and received in /any order/.
waitForAll :: HasCallStack => Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> [Aeson.Value] -> IO ()
waitForAll :: HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> [Value] -> IO ()
waitForAll Tracer IO HydraNodeLog
tracer NominalDiffTime
delay [HydraClient]
nodes [Value]
expected = do
  Tracer IO HydraNodeLog -> HydraNodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HydraNodeLog
tracer ([Int] -> [Value] -> HydraNodeLog
StartWaiting ((HydraClient -> Int) -> [HydraClient] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map HydraClient -> Int
hydraNodeId [HydraClient]
nodes) [Value]
expected)
  [HydraClient] -> (HydraClient -> IO ()) -> IO ()
forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
forConcurrently_ [HydraClient]
nodes ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \client :: HydraClient
client@HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} -> do
    IORef [Value]
msgs <- [Value] -> IO (IORef [Value])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []
    Maybe ()
result <- DiffTime -> IO () -> IO (Maybe ())
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout (NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
delay) (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ HydraClient -> IORef [Value] -> [Value] -> IO ()
tryNext HydraClient
client IORef [Value]
msgs [Value]
expected
    case Maybe ()
result of
      Just ()
x -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
x
      Maybe ()
Nothing -> do
        [Value]
actualMsgs <- IORef [Value] -> IO [Value]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [Value]
msgs
        String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
              [ Text
"waitForAll timed out after " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
forall b a. (Show a, IsString b) => a -> b
show NominalDiffTime
delay Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"s"
              , Char -> Int -> Text -> Text
padRight Char
' ' Int
20 Text
"  nodeId:"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId
              , Char -> Int -> Text -> Text
padRight Char
' ' Int
20 Text
"  expected:"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (Int -> [Text] -> [Text]
align Int
20 (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> Text) -> [Value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
expected))
              , Char -> Int -> Text -> Text
padRight Char
' ' Int
20 Text
"  seen messages:"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (Int -> [Text] -> [Text]
align Int
20 (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> Text) -> [Value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
actualMsgs))
              ]
 where
  align :: Int -> [Text] -> [Text]
align Int
_ [] = []
  align Int
n (Text
h : [Text]
q) = Text
h Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
T.replicate Int
n Text
" " <>) [Text]
q

  tryNext :: HydraClient -> IORef [Aeson.Value] -> [Aeson.Value] -> IO ()
  tryNext :: HydraClient -> IORef [Value] -> [Value] -> IO ()
tryNext c :: HydraClient
c@HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} IORef [Value]
msgs = \case
    [] -> Tracer IO HydraNodeLog -> HydraNodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HydraNodeLog
tracer (Int -> HydraNodeLog
EndWaiting Int
hydraNodeId)
    [Value]
stillExpected -> do
      Value
msg <- HasCallStack => HydraClient -> IO Value
HydraClient -> IO Value
waitNext HydraClient
c
      Tracer IO HydraNodeLog -> HydraNodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HydraNodeLog
tracer (Int -> Value -> HydraNodeLog
ReceivedMessage Int
hydraNodeId Value
msg)
      IORef [Value] -> ([Value] -> [Value]) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef [Value]
msgs (Value
msg :)
      case Value
msg of
        Object Object
km -> do
          let cleaned :: Value
cleaned = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
km Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"seq" Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"timestamp"
          HydraClient -> IORef [Value] -> [Value] -> IO ()
tryNext HydraClient
c IORef [Value]
msgs (Value -> [Value] -> [Value]
forall a. Eq a => a -> [a] -> [a]
List.delete Value
cleaned [Value]
stillExpected)
        Value
_ ->
          HydraClient -> IORef [Value] -> [Value] -> IO ()
tryNext HydraClient
c IORef [Value]
msgs [Value]
stillExpected

-- | Helper to make it easy to obtain a commit tx using some wallet utxo.
-- Create a commit tx using the hydra-node for later submission.
requestCommitTx :: HydraClient -> UTxO -> IO Tx
requestCommitTx :: HydraClient -> UTxO -> IO Tx
requestCommitTx HydraClient{$sel:apiHost:HydraClient :: HydraClient -> Host
apiHost = Host{Text
hostname :: Text
$sel:hostname:Host :: Host -> Text
hostname, PortNumber
port :: PortNumber
$sel:port:Host :: Host -> PortNumber
port}} UTxO
utxos =
  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))
request IO (JsonResponse (DraftCommitTxResponse Tx))
-> (JsonResponse (DraftCommitTxResponse Tx) -> Tx) -> IO Tx
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DraftCommitTxResponse Tx -> Tx
forall tx. DraftCommitTxResponse tx -> tx
commitTx (DraftCommitTxResponse Tx -> Tx)
-> (JsonResponse (DraftCommitTxResponse Tx)
    -> DraftCommitTxResponse Tx)
-> JsonResponse (DraftCommitTxResponse Tx)
-> Tx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonResponse (DraftCommitTxResponse Tx) -> DraftCommitTxResponse Tx
JsonResponse (DraftCommitTxResponse Tx)
-> HttpResponseBody (JsonResponse (DraftCommitTxResponse Tx))
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody
 where
  request :: Req (JsonResponse (DraftCommitTxResponse Tx))
request =
    POST
-> Url 'Http
-> ReqBodyJson (DraftCommitTxRequest Tx)
-> 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.req
      POST
POST
      (Text -> Url 'Http
Req.http Text
hostname Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"commit")
      (DraftCommitTxRequest Tx -> ReqBodyJson (DraftCommitTxRequest Tx)
forall a. a -> ReqBodyJson a
ReqBodyJson (DraftCommitTxRequest Tx -> ReqBodyJson (DraftCommitTxRequest Tx))
-> DraftCommitTxRequest Tx -> ReqBodyJson (DraftCommitTxRequest Tx)
forall a b. (a -> b) -> a -> b
$ forall tx. UTxOType tx -> DraftCommitTxRequest tx
SimpleCommitRequest @Tx UTxO
UTxOType Tx
utxos)
      (Proxy (JsonResponse (DraftCommitTxResponse Tx))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse (DraftCommitTxResponse Tx)))
      (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
Req.port (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (PortNumber -> Integer) -> PortNumber -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Integer
forall a. Integral a => a -> Integer
toInteger (PortNumber -> Int) -> PortNumber -> Int
forall a b. (a -> b) -> a -> b
$ PortNumber
port))

-- | Submit a decommit transaction to the hydra-node.
postDecommit :: HydraClient -> Tx -> IO ()
postDecommit :: HydraClient -> Tx -> IO ()
postDecommit HydraClient{$sel:apiHost:HydraClient :: HydraClient -> Host
apiHost = Host{Text
$sel:hostname:Host :: Host -> Text
hostname :: Text
hostname, PortNumber
$sel:port:Host :: Host -> PortNumber
port :: PortNumber
port}} Tx
decommitTx = do
  IO (Response ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Response ByteString) -> IO ())
-> IO (Response ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String
"POST http://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
hostname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PortNumber -> String
forall b a. (Show a, IsString b) => a -> b
show PortNumber
port String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/decommit")
      IO Request -> (Request -> Request) -> IO Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Tx -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON Tx
decommitTx
        IO Request
-> (Request -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs

-- | Get the latest snapshot UTxO from the hydra-node. NOTE: While we usually
-- avoid parsing responses using the same data types as the system under test,
-- this parses the response as a 'UTxO' type as we often need to pick it apart.
getSnapshotUTxO :: HydraClient -> IO UTxO
getSnapshotUTxO :: HydraClient -> IO UTxO
getSnapshotUTxO HydraClient{$sel:apiHost:HydraClient :: HydraClient -> Host
apiHost = Host{Text
$sel:hostname:Host :: Host -> Text
hostname :: Text
hostname, PortNumber
$sel:port:Host :: Host -> PortNumber
port :: PortNumber
port}} =
  HttpConfig -> Req (JsonResponse UTxO) -> IO (JsonResponse UTxO)
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig Req (JsonResponse UTxO)
request IO (JsonResponse UTxO) -> (JsonResponse UTxO -> UTxO) -> IO UTxO
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> JsonResponse UTxO -> UTxO
JsonResponse UTxO -> HttpResponseBody (JsonResponse UTxO)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody
 where
  request :: Req (JsonResponse UTxO)
request =
    GET
-> Url 'Http
-> NoReqBody
-> Proxy (JsonResponse UTxO)
-> Option 'Http
-> Req (JsonResponse UTxO)
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.req
      GET
GET
      (Text -> Url 'Http
Req.http Text
hostname Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"snapshot" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"utxo")
      NoReqBody
NoReqBody
      (Proxy (JsonResponse UTxO)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse UTxO))
      (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
Req.port (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (PortNumber -> Integer) -> PortNumber -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Integer
forall a. Integral a => a -> Integer
toInteger (PortNumber -> Int) -> PortNumber -> Int
forall a b. (a -> b) -> a -> b
$ PortNumber
port))

getMetrics :: HasCallStack => HydraClient -> IO ByteString
getMetrics :: HasCallStack => HydraClient -> IO ByteString
getMetrics HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId, $sel:apiHost:HydraClient :: HydraClient -> Host
apiHost = Host{Text
$sel:hostname:Host :: Host -> Text
hostname :: Text
hostname}} = do
  NominalDiffTime -> IO ByteString -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
3 (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$
    IO BsResponse -> IO (Either HttpException BsResponse)
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (HttpConfig -> Req BsResponse -> IO BsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig Req BsResponse
request) IO (Either HttpException BsResponse)
-> (Either HttpException BsResponse -> IO ByteString)
-> IO ByteString
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 (HttpException
e :: HttpException) -> String -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
"Request for hydra-node metrics failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HttpException -> String
forall b a. (Show a, IsString b) => a -> b
show HttpException
e
      Right BsResponse
body -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ BsResponse -> HttpResponseBody BsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
Req.responseBody BsResponse
body
 where
  request :: Req BsResponse
request =
    GET
-> Url 'Http
-> NoReqBody
-> Proxy BsResponse
-> Option 'Http
-> Req BsResponse
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.req
      GET
GET
      (Text -> Url 'Http
Req.http Text
hostname Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"metrics")
      NoReqBody
NoReqBody
      Proxy BsResponse
Req.bsResponse
      (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
Req.port (Int -> Option 'Http) -> Int -> Option 'Http
forall a b. (a -> b) -> a -> b
$ Int
6_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId)

data HydraNodeLog
  = HydraNodeCommandSpec {HydraNodeLog -> Text
cmd :: Text}
  | NodeStarted {HydraNodeLog -> Int
nodeId :: Int}
  | SentMessage {nodeId :: Int, HydraNodeLog -> Value
message :: Aeson.Value}
  | StartWaiting {HydraNodeLog -> [Int]
nodeIds :: [Int], HydraNodeLog -> [Value]
messages :: [Aeson.Value]}
  | ReceivedMessage {nodeId :: Int, message :: Aeson.Value}
  | EndWaiting {nodeId :: Int}
  deriving stock (HydraNodeLog -> HydraNodeLog -> Bool
(HydraNodeLog -> HydraNodeLog -> Bool)
-> (HydraNodeLog -> HydraNodeLog -> Bool) -> Eq HydraNodeLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HydraNodeLog -> HydraNodeLog -> Bool
== :: HydraNodeLog -> HydraNodeLog -> Bool
$c/= :: HydraNodeLog -> HydraNodeLog -> Bool
/= :: HydraNodeLog -> HydraNodeLog -> Bool
Eq, Int -> HydraNodeLog -> String -> String
[HydraNodeLog] -> String -> String
HydraNodeLog -> String
(Int -> HydraNodeLog -> String -> String)
-> (HydraNodeLog -> String)
-> ([HydraNodeLog] -> String -> String)
-> Show HydraNodeLog
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> HydraNodeLog -> String -> String
showsPrec :: Int -> HydraNodeLog -> String -> String
$cshow :: HydraNodeLog -> String
show :: HydraNodeLog -> String
$cshowList :: [HydraNodeLog] -> String -> String
showList :: [HydraNodeLog] -> String -> String
Show, (forall x. HydraNodeLog -> Rep HydraNodeLog x)
-> (forall x. Rep HydraNodeLog x -> HydraNodeLog)
-> Generic HydraNodeLog
forall x. Rep HydraNodeLog x -> HydraNodeLog
forall x. HydraNodeLog -> Rep HydraNodeLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HydraNodeLog -> Rep HydraNodeLog x
from :: forall x. HydraNodeLog -> Rep HydraNodeLog x
$cto :: forall x. Rep HydraNodeLog x -> HydraNodeLog
to :: forall x. Rep HydraNodeLog x -> HydraNodeLog
Generic)
  deriving anyclass ([HydraNodeLog] -> Value
[HydraNodeLog] -> Encoding
HydraNodeLog -> Bool
HydraNodeLog -> Value
HydraNodeLog -> Encoding
(HydraNodeLog -> Value)
-> (HydraNodeLog -> Encoding)
-> ([HydraNodeLog] -> Value)
-> ([HydraNodeLog] -> Encoding)
-> (HydraNodeLog -> Bool)
-> ToJSON HydraNodeLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HydraNodeLog -> Value
toJSON :: HydraNodeLog -> Value
$ctoEncoding :: HydraNodeLog -> Encoding
toEncoding :: HydraNodeLog -> Encoding
$ctoJSONList :: [HydraNodeLog] -> Value
toJSONList :: [HydraNodeLog] -> Value
$ctoEncodingList :: [HydraNodeLog] -> Encoding
toEncodingList :: [HydraNodeLog] -> Encoding
$comitField :: HydraNodeLog -> Bool
omitField :: HydraNodeLog -> Bool
ToJSON, Maybe HydraNodeLog
Value -> Parser [HydraNodeLog]
Value -> Parser HydraNodeLog
(Value -> Parser HydraNodeLog)
-> (Value -> Parser [HydraNodeLog])
-> Maybe HydraNodeLog
-> FromJSON HydraNodeLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser HydraNodeLog
parseJSON :: Value -> Parser HydraNodeLog
$cparseJSONList :: Value -> Parser [HydraNodeLog]
parseJSONList :: Value -> Parser [HydraNodeLog]
$comittedField :: Maybe HydraNodeLog
omittedField :: Maybe HydraNodeLog
FromJSON, TracingVerbosity -> HydraNodeLog -> Object
HydraNodeLog -> Object -> Text
(TracingVerbosity -> HydraNodeLog -> Object)
-> (HydraNodeLog -> Object -> Text) -> ToObject HydraNodeLog
forall a.
(TracingVerbosity -> a -> Object)
-> (a -> Object -> Text) -> ToObject a
$ctoObject :: TracingVerbosity -> HydraNodeLog -> Object
toObject :: TracingVerbosity -> HydraNodeLog -> Object
$ctextTransformer :: HydraNodeLog -> Object -> Text
textTransformer :: HydraNodeLog -> Object -> Text
ToObject)

-- XXX: The two lists need to be of same length. Also the verification keys can
-- be derived from the signing keys.
withHydraCluster ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  FilePath ->
  SocketPath ->
  -- | First node id
  -- This sets the starting point for assigning ports
  Int ->
  -- | NOTE: This decides on the size of the cluster!
  [(VerificationKey PaymentKey, SigningKey PaymentKey)] ->
  [SigningKey HydraKey] ->
  -- | Transaction id at which Hydra scripts should have been published.
  TxId ->
  ContestationPeriod ->
  (NonEmpty HydraClient -> IO a) ->
  IO a
withHydraCluster :: 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
tracer String
workDir SocketPath
nodeSocket Int
firstNodeId [(VerificationKey PaymentKey, SigningKey PaymentKey)]
allKeys [SigningKey HydraKey]
hydraKeys TxId
hydraScriptsTxId ContestationPeriod
contestationPeriod NonEmpty HydraClient -> IO a
action = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
clusterSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Cannot run a cluster with 0 number of nodes"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(VerificationKey PaymentKey, SigningKey PaymentKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(VerificationKey PaymentKey, SigningKey PaymentKey)]
allKeys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [SigningKey HydraKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SigningKey HydraKey]
hydraKeys) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Not matching number of cardano/hydra keys"

  [((VerificationKey PaymentKey, SigningKey PaymentKey), Int)]
-> (((VerificationKey PaymentKey, SigningKey PaymentKey), Int)
    -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(VerificationKey PaymentKey, SigningKey PaymentKey)]
-> [Int]
-> [((VerificationKey PaymentKey, SigningKey PaymentKey), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(VerificationKey PaymentKey, SigningKey PaymentKey)]
allKeys [Int]
allNodeIds) ((((VerificationKey PaymentKey, SigningKey PaymentKey), Int)
  -> IO ())
 -> IO ())
-> (((VerificationKey PaymentKey, SigningKey PaymentKey), Int)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \((VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk), Int
ix) -> do
    let vkFile :: File Any 'Out
vkFile = String -> File Any 'Out
forall content (direction :: FileDirection).
String -> File content direction
File (String -> File Any 'Out) -> String -> File Any 'Out
forall a b. (a -> b) -> a -> b
$ String
workDir String -> String -> String
</> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
ix String -> String -> String
<.> String
"vk"
    let skFile :: File Any 'Out
skFile = String -> File Any 'Out
forall content (direction :: FileDirection).
String -> File content direction
File (String -> File Any 'Out) -> String -> File Any 'Out
forall a b. (a -> b) -> a -> b
$ String
workDir String -> String -> String
</> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
ix String -> String -> String
<.> String
"sk"
    IO (Either (FileError ()) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (FileError ()) ()) -> IO ())
-> IO (Either (FileError ()) ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ File Any 'Out
-> Maybe TextEnvelopeDescr
-> VerificationKey PaymentKey
-> IO (Either (FileError ()) ())
forall a content.
HasTextEnvelope a =>
File content 'Out
-> Maybe TextEnvelopeDescr -> a -> IO (Either (FileError ()) ())
writeFileTextEnvelope File Any 'Out
vkFile Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing VerificationKey PaymentKey
vk
    IO (Either (FileError ()) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (FileError ()) ()) -> IO ())
-> IO (Either (FileError ()) ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 File Any 'Out
skFile Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing SigningKey PaymentKey
sk
  [HydraClient] -> [Int] -> IO a
startNodes [] [Int]
allNodeIds
 where
  clusterSize :: Int
clusterSize = [(VerificationKey PaymentKey, SigningKey PaymentKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(VerificationKey PaymentKey, SigningKey PaymentKey)]
allKeys
  allNodeIds :: [Int]
allNodeIds = [Int
firstNodeId .. Int
firstNodeId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
clusterSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

  startNodes :: [HydraClient] -> [Int] -> IO a
startNodes [HydraClient]
clients = \case
    [] -> NonEmpty HydraClient -> IO a
action ([Item (NonEmpty HydraClient)] -> NonEmpty HydraClient
forall l. IsList l => [Item l] -> l
fromList ([Item (NonEmpty HydraClient)] -> NonEmpty HydraClient)
-> [Item (NonEmpty HydraClient)] -> NonEmpty HydraClient
forall a b. (a -> b) -> a -> b
$ [HydraClient] -> [HydraClient]
forall a. [a] -> [a]
reverse [HydraClient]
clients)
    (Int
nodeId : [Int]
rest) -> do
      let hydraSigningKey :: SigningKey HydraKey
hydraSigningKey = [SigningKey HydraKey]
hydraKeys [SigningKey HydraKey] -> Int -> SigningKey HydraKey
forall a. HasCallStack => [a] -> Int -> a
Prelude.!! (Int
nodeId Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstNodeId)
          hydraVerificationKeys :: [VerificationKey HydraKey]
hydraVerificationKeys = (SigningKey HydraKey -> VerificationKey HydraKey)
-> [SigningKey HydraKey] -> [VerificationKey HydraKey]
forall a b. (a -> b) -> [a] -> [b]
map SigningKey HydraKey -> VerificationKey HydraKey
forall keyrole.
(Key keyrole, HasTypeProxy keyrole) =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey ([SigningKey HydraKey] -> [VerificationKey HydraKey])
-> [SigningKey HydraKey] -> [VerificationKey HydraKey]
forall a b. (a -> b) -> a -> b
$ (SigningKey HydraKey -> Bool)
-> [SigningKey HydraKey] -> [SigningKey HydraKey]
forall a. (a -> Bool) -> [a] -> [a]
filter (SigningKey HydraKey -> SigningKey HydraKey -> Bool
forall a. Eq a => a -> a -> Bool
/= SigningKey HydraKey
hydraSigningKey) [SigningKey HydraKey]
hydraKeys
          cardanoSigningKey :: String
cardanoSigningKey = String
workDir String -> String -> String
</> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
nodeId String -> String -> String
<.> String
"sk"
          cardanoVerificationKeys :: [String]
cardanoVerificationKeys = [String
workDir String -> String -> String
</> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
i String -> String -> String
<.> String
"vk" | Int
i <- [Int]
allNodeIds, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nodeId]
          chainConfig :: ChainConfig
chainConfig =
            DirectChainConfig -> ChainConfig
Direct
              DirectChainConfig
defaultDirectChainConfig
                { nodeSocket
                , hydraScriptsTxId
                , cardanoSigningKey
                , cardanoVerificationKeys
                , contestationPeriod
                }
      Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
forall a.
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode
        Tracer IO HydraNodeLog
tracer
        ChainConfig
chainConfig
        String
workDir
        Int
nodeId
        SigningKey HydraKey
hydraSigningKey
        [VerificationKey HydraKey]
hydraVerificationKeys
        [Int]
allNodeIds
        (\HydraClient
c -> [HydraClient] -> [Int] -> IO a
startNodes (HydraClient
c HydraClient -> [HydraClient] -> [HydraClient]
forall a. a -> [a] -> [a]
: [HydraClient]
clients) [Int]
rest)

-- | Run a hydra-node with given 'ChainConfig' and using the config from
-- config/.
withHydraNode ::
  Tracer IO HydraNodeLog ->
  ChainConfig ->
  FilePath ->
  Int ->
  SigningKey HydraKey ->
  [VerificationKey HydraKey] ->
  [Int] ->
  (HydraClient -> IO a) ->
  IO a
withHydraNode :: forall a.
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
hydraSKey [VerificationKey HydraKey]
hydraVKeys [Int]
allNodeIds HydraClient -> IO a
action = do
  String -> (Handle -> IO a) -> IO a
forall a. String -> (Handle -> IO a) -> IO a
withLogFile String
logFilePath ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
logFileHandle -> do
    Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> Maybe Handle
-> (Handle -> Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> Maybe Handle
-> (Handle -> Handle -> ProcessHandle -> IO a)
-> IO a
withHydraNode' Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
hydraSKey [VerificationKey HydraKey]
hydraVKeys [Int]
allNodeIds (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
logFileHandle) ((Handle -> Handle -> ProcessHandle -> IO a) -> IO a)
-> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ do
      \Handle
_ Handle
err ProcessHandle
processHandle -> do
        IO Void -> IO a -> IO (Either Void a)
forall a b. IO a -> IO b -> IO (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
race
          (Text -> ProcessHandle -> Maybe Handle -> IO Void
checkProcessHasNotDied (Text
"hydra-node (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") ProcessHandle
processHandle (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
err))
          (Tracer IO HydraNodeLog -> Int -> (HydraClient -> IO a) -> IO a
forall a.
Tracer IO HydraNodeLog -> Int -> (HydraClient -> IO a) -> IO a
withConnectionToNode Tracer IO HydraNodeLog
tracer Int
hydraNodeId HydraClient -> IO a
action)
          IO (Either Void a) -> (Either Void a -> a) -> IO a
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Void -> a) -> (a -> a) -> Either Void a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> a
forall a. Void -> a
absurd a -> a
forall a. a -> a
id
 where
  logFilePath :: String
logFilePath = String
workDir String -> String -> String
</> String
"logs" String -> String -> String
</> String
"hydra-node-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId String -> String -> String
<.> String
"log"

-- | Run a hydra-node with given 'ChainConfig' and using the config from
-- config/.
withHydraNode' ::
  Tracer IO HydraNodeLog ->
  ChainConfig ->
  FilePath ->
  Int ->
  SigningKey HydraKey ->
  [VerificationKey HydraKey] ->
  [Int] ->
  -- | If given use this as std out.
  Maybe Handle ->
  (Handle -> Handle -> ProcessHandle -> IO a) ->
  IO a
withHydraNode' :: forall a.
Tracer IO HydraNodeLog
-> ChainConfig
-> String
-> Int
-> SigningKey HydraKey
-> [VerificationKey HydraKey]
-> [Int]
-> Maybe Handle
-> (Handle -> Handle -> ProcessHandle -> IO a)
-> IO a
withHydraNode' Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig String
workDir Int
hydraNodeId SigningKey HydraKey
hydraSKey [VerificationKey HydraKey]
hydraVKeys [Int]
allNodeIds Maybe Handle
mGivenStdOut Handle -> Handle -> ProcessHandle -> IO a
action = do
  -- NOTE: AirPlay on MacOS uses 5000 and we must avoid it.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"darwin") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PortNumber
port PortNumber -> PortNumber -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldNotBe` (PortNumber
5_000 :: Network.PortNumber)
  String -> (String -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"hydra-node" ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
    let cardanoLedgerProtocolParametersFile :: String
cardanoLedgerProtocolParametersFile = String
dir String -> String -> String
</> String
"protocol-parameters.json"
    case ChainConfig
chainConfig of
      Offline OfflineChainConfig
_ ->
        String -> IO ByteString
readConfigFile String
"protocol-parameters.json"
          IO ByteString -> (ByteString -> 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
>>= String -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
writeFileBS String
cardanoLedgerProtocolParametersFile
      Direct DirectChainConfig{SocketPath
$sel:nodeSocket:DirectChainConfig :: DirectChainConfig -> SocketPath
nodeSocket :: SocketPath
nodeSocket, NetworkId
networkId :: NetworkId
$sel:networkId:DirectChainConfig :: DirectChainConfig -> NetworkId
networkId} -> do
        -- NOTE: This implicitly tests of cardano-cli with hydra-node
        Value
protocolParameters <- SocketPath -> NetworkId -> IO Value
cliQueryProtocolParameters SocketPath
nodeSocket NetworkId
networkId
        String -> Value -> IO ()
forall a. ToJSON a => String -> a -> IO ()
Aeson.encodeFile String
cardanoLedgerProtocolParametersFile (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
          Value
protocolParameters
            Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"txFeeFixed" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Scientific -> Value
Number Scientific
0)
            Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"txFeePerByte" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Scientific -> Value
Number Scientific
0)
            Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"executionUnitPrices" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe Value -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"priceMemory" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Scientific -> Value
Number Scientific
0)
            Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"executionUnitPrices" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe Value -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value (Maybe Value)
forall t. AsValue t => Key -> Traversal' t (Maybe Value)
atKey Key
"priceSteps" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Scientific -> Value
Number Scientific
0)

    let hydraSigningKey :: String
hydraSigningKey = String
dir String -> String -> String
</> (Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".sk")
    IO (Either (FileError ()) ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either (FileError ()) ()) -> IO ())
-> IO (Either (FileError ()) ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ File Any 'Out
-> Maybe TextEnvelopeDescr
-> SigningKey HydraKey
-> 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
hydraSigningKey) Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing SigningKey HydraKey
hydraSKey
    [String]
hydraVerificationKeys <- [(Int, VerificationKey HydraKey)]
-> ((Int, VerificationKey HydraKey) -> IO String) -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int]
-> [VerificationKey HydraKey] -> [(Int, VerificationKey HydraKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [VerificationKey HydraKey]
hydraVKeys) (((Int, VerificationKey HydraKey) -> IO String) -> IO [String])
-> ((Int, VerificationKey HydraKey) -> IO String) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \(Int
i :: Int, VerificationKey HydraKey
vKey) -> do
      let filepath :: String
filepath = String
dir String -> String -> String
</> (Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".vk")
      String
filepath String -> IO (Either (FileError ()) ()) -> IO String
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ File Any 'Out
-> Maybe TextEnvelopeDescr
-> VerificationKey HydraKey
-> 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
filepath) Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing VerificationKey HydraKey
vKey
    let p :: CreateProcess
p =
          ( RunOptions -> CreateProcess
hydraNodeProcess (RunOptions -> CreateProcess) -> RunOptions -> CreateProcess
forall a b. (a -> b) -> a -> b
$
              -- NOTE: Using 0.0.0.0 over 127.0.0.1 will make the hydra-node
              -- crash if it can't bind the interface and make tests fail more
              -- obvious when e.g. a hydra-node instance is already running.
              RunOptions
                { $sel:verbosity:RunOptions :: Verbosity
verbosity = Text -> Verbosity
Verbose Text
"HydraNode"
                , $sel:nodeId:RunOptions :: NodeId
nodeId = Text -> NodeId
NodeId (Text -> NodeId) -> Text -> NodeId
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId
                , $sel:host:RunOptions :: IP
host = IP
"0.0.0.0"
                , $sel:port:RunOptions :: PortNumber
port = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber) -> Int -> PortNumber
forall a b. (a -> b) -> a -> b
$ Int
5_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId
                , [Host]
peers :: [Host]
$sel:peers:RunOptions :: [Host]
peers
                , $sel:apiHost:RunOptions :: IP
apiHost = IP
"0.0.0.0"
                , $sel:apiPort:RunOptions :: PortNumber
apiPort = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber) -> Int -> PortNumber
forall a b. (a -> b) -> a -> b
$ Int
4_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId
                , $sel:tlsCertPath:RunOptions :: Maybe String
tlsCertPath = Maybe String
forall a. Maybe a
Nothing
                , $sel:tlsKeyPath:RunOptions :: Maybe String
tlsKeyPath = Maybe String
forall a. Maybe a
Nothing
                , $sel:monitoringPort:RunOptions :: Maybe PortNumber
monitoringPort = PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just (PortNumber -> Maybe PortNumber) -> PortNumber -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber) -> Int -> PortNumber
forall a b. (a -> b) -> a -> b
$ Int
6_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId
                , String
hydraSigningKey :: String
$sel:hydraSigningKey:RunOptions :: String
hydraSigningKey
                , [String]
hydraVerificationKeys :: [String]
$sel:hydraVerificationKeys:RunOptions :: [String]
hydraVerificationKeys
                , $sel:persistenceDir:RunOptions :: String
persistenceDir = String
workDir String -> String -> String
</> String
"state-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId
                , ChainConfig
chainConfig :: ChainConfig
$sel:chainConfig:RunOptions :: ChainConfig
chainConfig
                , $sel:ledgerConfig:RunOptions :: LedgerConfig
ledgerConfig =
                    CardanoLedgerConfig
                      { String
cardanoLedgerProtocolParametersFile :: String
$sel:cardanoLedgerProtocolParametersFile:CardanoLedgerConfig :: String
cardanoLedgerProtocolParametersFile
                      }
                }
          )
            { std_out = maybe CreatePipe UseHandle mGivenStdOut
            , std_err = CreatePipe
            }

    Tracer IO HydraNodeLog -> HydraNodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HydraNodeLog
tracer (HydraNodeLog -> IO ()) -> HydraNodeLog -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> HydraNodeLog
HydraNodeCommandSpec (Text -> HydraNodeLog) -> Text -> HydraNodeLog
forall a b. (a -> b) -> a -> b
$ CmdSpec -> Text
forall b a. (Show a, IsString b) => a -> b
show (CmdSpec -> Text) -> CmdSpec -> Text
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CmdSpec
cmdspec CreateProcess
p

    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
p ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
 -> IO a)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_stdin Maybe Handle
mCreatedStdOut Maybe Handle
mCreatedStdErr ProcessHandle
processHandle ->
      case (Maybe Handle
mCreatedStdOut Maybe Handle -> Maybe Handle -> Maybe Handle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Handle
mGivenStdOut, Maybe Handle
mCreatedStdErr) of
        (Just Handle
out, Just Handle
err) -> Handle -> Handle -> ProcessHandle -> IO a
action Handle
out Handle
err ProcessHandle
processHandle
        (Maybe Handle
Nothing, Maybe Handle
_) -> Text -> IO a
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Should not happen™"
        (Maybe Handle
_, Maybe Handle
Nothing) -> Text -> IO a
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Should not happen™"
 where
  port :: PortNumber
port = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber) -> Int -> PortNumber
forall a b. (a -> b) -> a -> b
$ Int
5_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hydraNodeId

  peers :: [Host]
peers =
    [ Host
      { $sel:hostname:Host :: Text
Network.hostname = Text
"127.0.0.1"
      , $sel:port:Host :: PortNumber
Network.port = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber) -> Int -> PortNumber
forall a b. (a -> b) -> a -> b
$ Int
5_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
      }
    | Int
i <- [Int]
allNodeIds
    , Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
hydraNodeId
    ]

withConnectionToNode :: forall a. Tracer IO HydraNodeLog -> Int -> (HydraClient -> IO a) -> IO a
withConnectionToNode :: forall a.
Tracer IO HydraNodeLog -> Int -> (HydraClient -> IO a) -> IO a
withConnectionToNode Tracer IO HydraNodeLog
tracer Int
hydraNodeId =
  Tracer IO HydraNodeLog
-> Int -> Host -> Maybe String -> (HydraClient -> IO a) -> IO a
forall a.
Tracer IO HydraNodeLog
-> Int -> Host -> Maybe String -> (HydraClient -> IO a) -> IO a
withConnectionToNodeHost Tracer IO HydraNodeLog
tracer Int
hydraNodeId Host{Text
$sel:hostname:Host :: Text
hostname :: Text
hostname, PortNumber
$sel:port:Host :: PortNumber
port :: PortNumber
port} Maybe String
forall a. Maybe a
Nothing
 where
  hostname :: Text
hostname = Text
"127.0.0.1"
  port :: PortNumber
port = Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber) -> Integer -> PortNumber
forall a b. (a -> b) -> a -> b
$ Integer
4_000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
hydraNodeId

withConnectionToNodeHost :: forall a. Tracer IO HydraNodeLog -> Int -> Host -> Maybe String -> (HydraClient -> IO a) -> IO a
withConnectionToNodeHost :: forall a.
Tracer IO HydraNodeLog
-> Int -> Host -> Maybe String -> (HydraClient -> IO a) -> IO a
withConnectionToNodeHost Tracer IO HydraNodeLog
tracer Int
hydraNodeId apiHost :: Host
apiHost@Host{Text
$sel:hostname:Host :: Host -> Text
hostname :: Text
hostname, PortNumber
$sel:port:Host :: Host -> PortNumber
port :: PortNumber
port} Maybe String
queryParams HydraClient -> IO a
action = do
  IORef Bool
connectedOnce <- Bool -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Bool
False
  IORef Bool -> Int -> IO a
tryConnect IORef Bool
connectedOnce (Int
200 :: Int)
 where
  tryConnect :: IORef Bool -> Int -> IO a
tryConnect IORef Bool
connectedOnce Int
n
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Timed out waiting for connection to hydra-node " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId
    | Bool
otherwise = do
        let
          retryOrThrow :: forall proxy e. Exception e => proxy e -> e -> IO a
          retryOrThrow :: forall (proxy :: * -> *) e. Exception e => proxy e -> e -> IO a
retryOrThrow proxy e
_ e
e =
            IORef Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Bool
connectedOnce IO Bool -> (Bool -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
False -> DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1 IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef Bool -> Int -> IO a
tryConnect IORef Bool
connectedOnce (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              Bool
True -> e -> IO a
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
        IORef Bool -> IO a
doConnect IORef Bool
connectedOnce
          IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
`catches` [ (IOException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((IOException -> IO a) -> Handler a)
-> (IOException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ Proxy IOException -> IOException -> IO a
forall (proxy :: * -> *) e. Exception e => proxy e -> e -> IO a
retryOrThrow (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @IOException)
                    , (HandshakeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((HandshakeException -> IO a) -> Handler a)
-> (HandshakeException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ Proxy HandshakeException -> HandshakeException -> IO a
forall (proxy :: * -> *) e. Exception e => proxy e -> e -> IO a
retryOrThrow (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @HandshakeException)
                    ]

  historyMode :: String
historyMode = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"/" Maybe String
queryParams

  doConnect :: IORef Bool -> IO a
doConnect IORef Bool
connectedOnce = String -> Int -> String -> ClientApp a -> IO a
forall a. String -> Int -> String -> ClientApp a -> IO a
runClient (Text -> String
T.unpack Text
hostname) (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (PortNumber -> Integer) -> PortNumber -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Integer
forall a. Integral a => a -> Integer
toInteger (PortNumber -> Int) -> PortNumber -> Int
forall a b. (a -> b) -> a -> b
$ PortNumber
port) String
historyMode (ClientApp a -> IO a) -> ClientApp a -> IO a
forall a b. (a -> b) -> a -> b
$
    \Connection
connection -> do
      IORef Bool -> Bool -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef Bool
connectedOnce Bool
True
      Tracer IO HydraNodeLog -> HydraNodeLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HydraNodeLog
tracer (Int -> HydraNodeLog
NodeStarted Int
hydraNodeId)
      a
res <- HydraClient -> IO a
action (HydraClient -> IO a) -> HydraClient -> IO a
forall a b. (a -> b) -> a -> b
$ HydraClient{Int
$sel:hydraNodeId:HydraClient :: Int
hydraNodeId :: Int
hydraNodeId, Host
$sel:apiHost:HydraClient :: Host
apiHost :: Host
apiHost, Connection
$sel:connection:HydraClient :: Connection
connection :: Connection
connection, Tracer IO HydraNodeLog
$sel:tracer:HydraClient :: Tracer IO HydraNodeLog
tracer :: Tracer IO HydraNodeLog
tracer}
      Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendClose Connection
connection (Text
"Bye" :: Text)
      a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

hydraNodeProcess :: RunOptions -> CreateProcess
hydraNodeProcess :: RunOptions -> CreateProcess
hydraNodeProcess = String -> [String] -> CreateProcess
proc String
"hydra-node" ([String] -> CreateProcess)
-> (RunOptions -> [String]) -> RunOptions -> CreateProcess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunOptions -> [String]
toArgs

waitForNodesConnected :: HasCallStack => Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesConnected :: HasCallStack =>
Tracer IO HydraNodeLog -> NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
tracer NominalDiffTime
delay [HydraClient]
clients =
  (HydraClient -> IO ()) -> [HydraClient] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HydraClient -> IO ()
waitForNodeConnected [HydraClient]
clients
 where
  allNodeIds :: [Int]
allNodeIds = HydraClient -> Int
hydraNodeId (HydraClient -> Int) -> [HydraClient] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HydraClient]
clients
  waitForNodeConnected :: HydraClient -> IO ()
waitForNodeConnected n :: HydraClient
n@HydraClient{Int
$sel:hydraNodeId:HydraClient :: HydraClient -> Int
hydraNodeId :: Int
hydraNodeId} =
    HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> [Value] -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> [Value] -> IO ()
waitForAll Tracer IO HydraNodeLog
tracer NominalDiffTime
delay [HydraClient
n] ([Value] -> IO ()) -> [Value] -> IO ()
forall a b. (a -> b) -> a -> b
$
      (Int -> Value) -> [Int] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( \Int
nodeId ->
            [Pair] -> Value
object
              [ Key
"tag" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"PeerConnected"
              , Key
"peer" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
nodeId)
              ]
        )
        ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
hydraNodeId) [Int]
allNodeIds)