{-# LANGUAGE DuplicateRecordFields #-}

module HydraNode (
  module HydraNode,
  HydraNodeLog (..),
) where

import Hydra.Cardano.Api hiding (getVerificationKey)
import Hydra.Prelude hiding (STM, delete)

import Cardano.Binary (serialize')
import CardanoNode (HydraNodeLog (..), cliQueryProtocolParameters)
import Control.Concurrent.Async (forConcurrently_)
import Control.Concurrent.Class.MonadSTM (modifyTVar', 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, _String)
import Data.Aeson.Types (Pair)
import Data.ByteString (hGetContents)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Hydra.API.ClientInput (ClientInput)
import Hydra.API.HTTPServer (DraftCommitTxRequest (..), DraftCommitTxResponse (..))
import Hydra.API.ServerOutput (ApiEncoding (..), ApiMessage)
import Hydra.API.WireFormat (decodeWire)
import Hydra.Chain.Blockfrost.Client qualified as Blockfrost
import Hydra.Cluster.Util (Timing (..), readConfigFile)
import Hydra.Logging (Tracer, Verbosity (..), traceWith)
import Hydra.Network (Host (Host), NodeId (NodeId), WhichEtcd (SystemEtcd))
import Hydra.Network qualified as Network
import Hydra.Network.Etcd (peerPortToClientPort)
import Hydra.Options (BlockfrostOptions (..), CardanoChainConfig (..), ChainBackendOptions (..), ChainConfig (..), DirectOptions (..), LedgerConfig (..), RunOptions (..), defaultCardanoChainConfig, defaultDirectOptions, nodeSocket, toArgs)
import Hydra.Tx (ConfirmedSnapshot)
import Hydra.Tx.Crypto (HydraKey, getVerificationKey)
import Hydra.Tx.Secret (Secret, withSecret)
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 (getResponseBody, httpJSON, httpLbs, setRequestBodyJSON)
import Network.WebSockets (Connection, ConnectionException, HandshakeException, receiveData, runClient, sendBinaryData, sendClose, sendTextData)
import System.Directory (createDirectoryIfMissing)
import System.Environment (getEnvironment)
import System.FilePath ((<.>), (</>))
import System.IO.Unsafe (unsafePerformIO)
import System.Info (os)
import System.Process.Typed (
  ExitCode (..),
  createPipe,
  getStderr,
  proc,
  setCloseFds,
  setEnv,
  setStderr,
  setStdout,
  useHandleOpen,
  waitExitCode,
  withProcessTerm,
 )
import Test.Hydra.Prelude (failure, shouldBe)
import Test.Hydra.Prelude qualified as Prelude
import Test.Network.Ports (randomUnusedTCPPorts, randomUnusedTCPPortsWithDerived)
import Prelude qualified

-- * Client to interact with a hydra-node

data HydraClient = HydraClient
  { HydraClient -> Int
hydraNodeId :: Int
  , HydraClient -> Host
apiHost :: Host
  , HydraClient -> Maybe PortNumber
monitoringPort :: Maybe Network.PortNumber
  -- ^ Port the hydra-node exposes Prometheus metrics on, if enabled.
  , HydraClient -> Connection
connection :: Connection
  , HydraClient -> Tracer IO HydraNodeLog
tracer :: Tracer IO HydraNodeLog
  , HydraClient -> ApiEncoding
apiEncoding :: ApiEncoding
  -- ^ Which wire encoding was negotiated for 'connection' (via the
  -- @encoding=cbor@ query param). 'send' and 'waitNext' translate between
  -- CBOR on the wire and the 'Aeson.Value's used by test assertions.
  , HydraClient -> Maybe FilePath
workDir :: Maybe FilePath
  -- ^ Work directory of the spawned hydra-node, when this test spawned it;
  -- used to point at its logs in failure messages.
  }

-- | 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, ApiEncoding
$sel:apiEncoding:HydraClient :: HydraClient -> ApiEncoding
apiEncoding :: ApiEncoding
apiEncoding} Value
v = do
  case ApiEncoding
apiEncoding of
    ApiEncoding
JsonEncoding -> 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)
    ApiEncoding
CborEncoding ->
      -- Convert the 'Aeson.Value' to a typed 'ClientInput' and send its CBOR.
      case Value -> Result (ClientInput Tx)
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
v of
        Aeson.Error FilePath
err -> FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"send: cannot convert to ClientInput for CBOR encoding: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err
        Aeson.Success (ClientInput Tx
clientInput :: ClientInput Tx) ->
          Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendBinaryData Connection
connection (ClientInput Tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize' ClientInput Tx
clientInput)
  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, ApiEncoding
$sel:apiEncoding:HydraClient :: HydraClient -> ApiEncoding
apiEncoding :: ApiEncoding
apiEncoding} = 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
        FilePath -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"waitNext: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ConnectionException -> FilePath
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 ApiEncoding
apiEncoding of
    ApiEncoding
JsonEncoding ->
      case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecode' ByteString
bytes of
        Left FilePath
err -> FilePath -> IO Value
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO Value) -> FilePath -> IO Value
forall a b. (a -> b) -> a -> b
$ FilePath
"WaitNext failed to decode msg: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err
        Right Value
value -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
    ApiEncoding
CborEncoding ->
      -- Decode the typed message and re-encode as a JSON 'Aeson.Value', so
      -- that existing lens-based assertions keep working unchanged.
      case ApiEncoding -> ByteString -> Either FilePath (ApiMessage Tx)
forall a.
(FromJSON a, FromCBOR a) =>
ApiEncoding -> ByteString -> Either FilePath a
decodeWire ApiEncoding
CborEncoding ByteString
bytes of
        Left FilePath
err -> FilePath -> IO Value
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO Value) -> FilePath -> IO Value
forall a b. (a -> b) -> a -> b
$ FilePath
"WaitNext failed to decode CBOR msg: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err
        Right (ApiMessage Tx
msg :: ApiMessage Tx) -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> IO Value) -> Value -> IO Value
forall a b. (a -> b) -> a -> b
$ ApiMessage Tx -> Value
forall a. ToJSON a => a -> Value
toJSON ApiMessage Tx
msg

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

-- | Scale a wait budget to the environment. Blockfrost runs triple it (the
-- follower observes ~1 block behind tip plus one poll interval, on a network
-- with much longer block times than the devnet timings most waits are written
-- for) and HYDRA_TEST_WAIT_MULTIPLIER multiplies further; CI sets it to
-- compensate for slow shared runners, local runs default to 1. Only failure
-- latency is affected: a passing wait returns as soon as its message arrives.
--
-- Budgets get a constant floor: the many @N * blockTime@ waits come to well
-- under a second on the 0.1s devnet, underestimating the fixed costs they
-- also cover (tx submission, observation, node processing). Sub-second waits
-- fired exactly when several suites shared one machine.
scaleWaitTime :: NominalDiffTime -> IO NominalDiffTime
scaleWaitTime :: NominalDiffTime -> IO NominalDiffTime
scaleWaitTime NominalDiffTime
d = do
  NominalDiffTime
bf <-
    IO HydraTestnet
Prelude.getHydraNetwork IO HydraTestnet
-> (HydraTestnet -> IO NominalDiffTime) -> IO NominalDiffTime
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      HydraTestnet
Prelude.Blockfrost -> NominalDiffTime -> IO NominalDiffTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NominalDiffTime
3
      HydraTestnet
_backend -> NominalDiffTime -> IO NominalDiffTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NominalDiffTime
1
  NominalDiffTime
multiplier <- NominalDiffTime
-> (Double -> NominalDiffTime) -> Maybe Double -> NominalDiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NominalDiffTime
1 (forall a b. (Real a, Fractional b) => a -> b
realToFrac @Double) (Maybe Double -> NominalDiffTime)
-> (Maybe FilePath -> Maybe Double)
-> Maybe FilePath
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Maybe Double
forall a. Read a => FilePath -> Maybe a
readMaybe =<<) (Maybe FilePath -> NominalDiffTime)
-> IO (Maybe FilePath) -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
"HYDRA_TEST_WAIT_MULTIPLIER"
  NominalDiffTime -> IO NominalDiffTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NominalDiffTime -> IO NominalDiffTime)
-> NominalDiffTime -> IO NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
max NominalDiffTime
5 (NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
bf NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
multiplier)

-- | 'failAfter' with the budget scaled like 'scaleWaitTime'. Use for
-- whole-test backstops in end-to-end tests.
scaledFailAfter :: HasCallStack => NominalDiffTime -> IO a -> IO a
scaledFailAfter :: forall a. HasCallStack => NominalDiffTime -> IO a -> IO a
scaledFailAfter NominalDiffTime
seconds IO a
action = NominalDiffTime -> IO NominalDiffTime
scaleWaitTime NominalDiffTime
seconds IO NominalDiffTime -> (NominalDiffTime -> 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
>>= (NominalDiffTime -> IO a -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
`Prelude.failAfter` IO a
action)

-- | 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 and succeed if no API server output matches the given predicate.
-- The window is deliberately NOT scaled by 'scaleWaitTime': the timeout here
-- is the success path, so scaling it would slow every passing run.
waitNoMatch :: HasCallStack => NominalDiffTime -> HydraClient -> (Aeson.Value -> Maybe a) -> IO ()
waitNoMatch :: forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO ()
waitNoMatch NominalDiffTime
delay HydraClient
client Value -> Maybe a
match = do
  Either SomeException ()
result <- IO () -> IO (Either SomeException ())
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 (IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatchWith NominalDiffTime
delay HydraClient
client Value -> Maybe a
match) :: IO (Either SomeException ())
  case Either SomeException ()
result of
    Left SomeException
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Success: waitMatch failed to find a match
    Right ()
_ -> FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure FilePath
"waitNoMatch: A match was found when none was expected"

-- | Wait up to some time for an API server output to match the given predicate.
-- The budget is scaled to the environment, see 'scaleWaitTime'.
waitMatch :: HasCallStack => NominalDiffTime -> HydraClient -> (Aeson.Value -> Maybe a) -> IO a
waitMatch :: forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
delay' HydraClient
client Value -> Maybe a
match = do
  NominalDiffTime
delay <- NominalDiffTime -> IO NominalDiffTime
scaleWaitTime NominalDiffTime
delay'
  NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatchWith NominalDiffTime
delay HydraClient
client Value -> Maybe a
match

-- | Like 'waitMatch' but with the given wall-clock budget, unscaled.
waitMatchWith :: HasCallStack => NominalDiffTime -> HydraClient -> (Aeson.Value -> Maybe a) -> IO a
waitMatchWith :: forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatchWith 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, Maybe FilePath
$sel:workDir:HydraClient :: HydraClient -> Maybe FilePath
workDir :: Maybe FilePath
workDir} Value -> Maybe a
match = do
  TVar [Value]
seenMsgs <- FilePath -> [Value] -> IO (TVar IO [Value])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
FilePath -> a -> m (TVar m a)
newLabelledTVarIO FilePath
"wait-match-seen-msgs" []
  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
      FilePath -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$
        Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> Text -> FilePath
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
"  node logs:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (FilePath -> Text) -> Maybe FilePath -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<not spawned by this test>" (\FilePath
d -> FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
"logs")) Maybe FilePath
workDir
            , 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
$
    FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure FilePath
"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
    [] -> FilePath -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"empty results, but " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
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) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" 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
$
        FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"inconsistent results: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [a] -> FilePath
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
d [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)
  NominalDiffTime
delay <- NominalDiffTime -> IO NominalDiffTime
scaleWaitTime NominalDiffTime
d
  [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
        FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> Text -> FilePath
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
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
utxo =
  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
utxo)
      (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
$
    FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseUrlThrow (FilePath
"POST http://" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
hostname FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> PortNumber -> FilePath
forall b a. (Show a, IsString b) => a -> b
show PortNumber
port FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/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 protocol-parameters from the hydra-node.
getProtocolParameters :: HydraClient -> IO (PParams LedgerEra)
getProtocolParameters :: HydraClient -> IO (PParams LedgerEra)
getProtocolParameters 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}} =
  FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseUrlThrow (FilePath
"GET http://" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
hostname FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> PortNumber -> FilePath
forall b a. (Show a, IsString b) => a -> b
show PortNumber
port FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/protocol-parameters")
    IO Request
-> (Request -> IO (Response (PParams ConwayEra)))
-> IO (Response (PParams ConwayEra))
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 (PParams ConwayEra))
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
    IO (Response (PParams ConwayEra))
-> (Response (PParams ConwayEra) -> PParams ConwayEra)
-> IO (PParams ConwayEra)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response (PParams ConwayEra) -> PParams ConwayEra
forall a. Response a -> a
getResponseBody

-- | 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}} =
  FilePath -> IO Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseUrlThrow (FilePath
"GET http://" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
hostname FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> PortNumber -> FilePath
forall b a. (Show a, IsString b) => a -> b
show PortNumber
port FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/snapshot/utxo")
    IO Request -> (Request -> IO (Response UTxO)) -> IO (Response UTxO)
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 UTxO)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON
    IO (Response UTxO) -> (Response UTxO -> UTxO) -> IO UTxO
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response UTxO -> UTxO
forall a. Response a -> a
getResponseBody

-- | Wait for the node's confirmed snapshot to hold exactly the given 'UTxO'.
--
-- NOTE: @/snapshot/utxo@ serves the latest confirmed snapshot, which can still
-- predate an increment or decommit just after its finalisation event. Sampling
-- it once therefore races on a slow machine, reporting the UTxO as it was one
-- snapshot ago. The last value seen is kept so that a genuine mismatch is still
-- reported as a mismatch, rather than as a bare timeout.
waitForSnapshotUTxO :: HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO :: HasCallStack => NominalDiffTime -> HydraClient -> UTxO -> IO ()
waitForSnapshotUTxO NominalDiffTime
delay HydraClient
node UTxO
expected = do
  IORef UTxO
lastSeen <- UTxO -> IO (IORef UTxO)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef UTxO
forall a. Monoid a => a
mempty
  IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ())
-> (IO () -> IO (Maybe ())) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef UTxO -> IO ()
poll IORef UTxO
lastSeen
  IORef UTxO -> IO UTxO
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef UTxO
lastSeen IO UTxO -> (UTxO -> 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
>>= (UTxO -> UTxO -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UTxO
expected)
 where
  poll :: IORef UTxO -> IO ()
poll IORef UTxO
lastSeen = do
    UTxO
utxo <- HydraClient -> IO UTxO
getSnapshotUTxO HydraClient
node
    IORef UTxO -> UTxO -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef UTxO
lastSeen UTxO
utxo
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UTxO
utxo UTxO -> UTxO -> Bool
forall a. Eq a => a -> a -> Bool
== UTxO
expected) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef UTxO -> IO ()
poll IORef UTxO
lastSeen

-- | Get the latest snapshot 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 'ConfirmedSnapshot' type as we often need to pick it apart.
getSnapshotConfirmed :: HydraClient -> IO (ConfirmedSnapshot Tx)
getSnapshotConfirmed :: HydraClient -> IO (ConfirmedSnapshot Tx)
getSnapshotConfirmed 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 (ConfirmedSnapshot Tx))
-> IO (JsonResponse (ConfirmedSnapshot Tx))
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig Req (JsonResponse (ConfirmedSnapshot Tx))
request IO (JsonResponse (ConfirmedSnapshot Tx))
-> (JsonResponse (ConfirmedSnapshot Tx) -> ConfirmedSnapshot Tx)
-> IO (ConfirmedSnapshot Tx)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> JsonResponse (ConfirmedSnapshot Tx) -> ConfirmedSnapshot Tx
JsonResponse (ConfirmedSnapshot Tx)
-> HttpResponseBody (JsonResponse (ConfirmedSnapshot Tx))
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody
 where
  request :: Req (JsonResponse (ConfirmedSnapshot Tx))
request =
    GET
-> Url 'Http
-> NoReqBody
-> Proxy (JsonResponse (ConfirmedSnapshot Tx))
-> Option 'Http
-> Req (JsonResponse (ConfirmedSnapshot 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
      GET
GET
      (Text -> Url 'Http
Req.http Text
hostname Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"snapshot")
      NoReqBody
NoReqBody
      (Proxy (JsonResponse (ConfirmedSnapshot Tx))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (JsonResponse (ConfirmedSnapshot 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))

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}, Maybe PortNumber
$sel:monitoringPort:HydraClient :: HydraClient -> Maybe PortNumber
monitoringPort :: Maybe PortNumber
monitoringPort} = do
  PortNumber
metricsPort <- case Maybe PortNumber
monitoringPort of
    Just PortNumber
p -> PortNumber -> IO PortNumber
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PortNumber
p
    Maybe PortNumber
Nothing -> FilePath -> IO PortNumber
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO PortNumber) -> FilePath -> IO PortNumber
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot fetch metrics: hydra-node " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" has no monitoringPort configured."
  NominalDiffTime -> IO ByteString -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
Prelude.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 (PortNumber -> Req BsResponse
request PortNumber
metricsPort)) 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) -> FilePath -> IO ByteString
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Request for hydra-node metrics failed: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> HttpException -> FilePath
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 :: PortNumber -> Req BsResponse
request PortNumber
metricsPort =
    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 (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
metricsPort))

-- * Start / connect to a cluster of nodes

-- 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 ->
  Timing ->
  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, Secret (SigningKey PaymentKey))] ->
  [Secret (SigningKey HydraKey)] ->
  -- | Transaction ids at which Hydra scripts should have been published.
  [TxId] ->
  (NonEmpty HydraClient -> IO a) ->
  IO a
withHydraCluster :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> Timing
-> FilePath
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> [Secret (SigningKey HydraKey)]
-> [TxId]
-> (NonEmpty HydraClient -> IO a)
-> IO a
withHydraCluster = Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> Timing
-> FilePath
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> [Secret (SigningKey HydraKey)]
-> [TxId]
-> (NonEmpty HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> Timing
-> FilePath
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> [Secret (SigningKey HydraKey)]
-> [TxId]
-> (NonEmpty HydraClient -> IO a)
-> IO a
withHydraClusterWith Maybe FilePath
forall a. Maybe a
Nothing RunOptions -> RunOptions
forall a. a -> a
id

-- | Like 'withHydraCluster' but connecting each node's API client with the
-- given query string (e.g. "/?history=yes&snapshot-utxo=no") instead of the
-- default "/?history=yes", and adjusting each node's 'RunOptions' (e.g. to
-- disable logging) before it is started.
withHydraClusterWith ::
  HasCallStack =>
  Maybe String ->
  (RunOptions -> RunOptions) ->
  Tracer IO HydraNodeLog ->
  Timing ->
  FilePath ->
  SocketPath ->
  Int ->
  [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))] ->
  [Secret (SigningKey HydraKey)] ->
  [TxId] ->
  (NonEmpty HydraClient -> IO a) ->
  IO a
withHydraClusterWith :: forall a.
HasCallStack =>
Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> Timing
-> FilePath
-> SocketPath
-> Int
-> [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> [Secret (SigningKey HydraKey)]
-> [TxId]
-> (NonEmpty HydraClient -> IO a)
-> IO a
withHydraClusterWith Maybe FilePath
mQueryParams RunOptions -> RunOptions
mapOptions Tracer IO HydraNodeLog
tracer Timing
timing FilePath
workDir SocketPath
nodeSocket Int
firstNodeId [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
allKeys [Secret (SigningKey HydraKey)]
hydraKeys [TxId]
hydraScriptsTxId 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
$
    FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure FilePath
"Cannot run a cluster with 0 number of nodes"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
allKeys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Secret (SigningKey HydraKey)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Secret (SigningKey HydraKey)]
hydraKeys) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure FilePath
"Not matching number of cardano/hydra keys"

  [((VerificationKey PaymentKey, Secret (SigningKey PaymentKey)),
  Int)]
-> (((VerificationKey PaymentKey, Secret (SigningKey PaymentKey)),
     Int)
    -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> [Int]
-> [((VerificationKey PaymentKey, Secret (SigningKey PaymentKey)),
     Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
allKeys [Int]
allNodeIds) ((((VerificationKey PaymentKey, Secret (SigningKey PaymentKey)),
   Int)
  -> IO ())
 -> IO ())
-> (((VerificationKey PaymentKey, Secret (SigningKey PaymentKey)),
     Int)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \((VerificationKey PaymentKey
vk, Secret (SigningKey PaymentKey)
sk), Int
ix) -> do
    let vkFile :: File Any 'Out
vkFile = FilePath -> File Any 'Out
forall content (direction :: FileDirection).
FilePath -> File content direction
File (FilePath -> File Any 'Out) -> FilePath -> File Any 'Out
forall a b. (a -> b) -> a -> b
$ FilePath
workDir FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
ix FilePath -> FilePath -> FilePath
<.> FilePath
"vk"
    let skFile :: File Any 'Out
skFile = FilePath -> File Any 'Out
forall content (direction :: FileDirection).
FilePath -> File content direction
File (FilePath -> File Any 'Out) -> FilePath -> File Any 'Out
forall a b. (a -> b) -> a -> b
$ FilePath
workDir FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
ix FilePath -> FilePath -> FilePath
<.> FilePath
"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
$ Secret (SigningKey PaymentKey)
-> (SigningKey PaymentKey -> IO (Either (FileError ()) ()))
-> IO (Either (FileError ()) ())
forall a r. Secret a -> (a -> r) -> r
withSecret Secret (SigningKey PaymentKey)
sk (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)
  Map Int HydraNodePorts
nodePorts <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int]
allNodeIds
  Map Int HydraNodePorts -> [HydraClient] -> [Int] -> IO a
startNodes Map Int HydraNodePorts
nodePorts [] [Int]
allNodeIds
 where
  clusterSize :: Int
clusterSize = [(VerificationKey PaymentKey, Secret (SigningKey PaymentKey))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(VerificationKey PaymentKey, Secret (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 :: Map Int HydraNodePorts -> [HydraClient] -> [Int] -> IO a
startNodes Map Int HydraNodePorts
nodePorts [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 :: Secret (SigningKey HydraKey)
hydraSigningKey = [Secret (SigningKey HydraKey)]
hydraKeys [Secret (SigningKey HydraKey)]
-> Int -> Secret (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 =
            [Secret (SigningKey HydraKey) -> VerificationKey HydraKey
forall s k. HasVerificationKey s k => s -> VerificationKey k
getVerificationKey Secret (SigningKey HydraKey)
sk | Secret (SigningKey HydraKey)
sk <- [Secret (SigningKey HydraKey)]
hydraKeys, Secret (SigningKey HydraKey)
sk Secret (SigningKey HydraKey)
-> Secret (SigningKey HydraKey) -> Bool
forall a. Eq a => a -> a -> Bool
/= Secret (SigningKey HydraKey)
hydraSigningKey]
          cardanoSigningKey :: FilePath
cardanoSigningKey = FilePath
workDir FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
nodeId FilePath -> FilePath -> FilePath
<.> FilePath
"sk"
          cardanoVerificationKeys :: [FilePath]
cardanoVerificationKeys = [FilePath
workDir FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
i FilePath -> FilePath -> FilePath
<.> FilePath
"vk" | Int
i <- [Int]
allNodeIds, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nodeId]
          chainConfig :: ChainConfig
chainConfig =
            CardanoChainConfig -> ChainConfig
Cardano
              CardanoChainConfig
defaultCardanoChainConfig
                { hydraScriptsTxId
                , cardanoSigningKey
                , cardanoVerificationKeys
                , contestationPeriod
                , depositPeriod
                , depositActivation
                , chainBackendOptions =
                    Direct
                      defaultDirectOptions
                        { nodeSocket = nodeSocket
                        }
                }
      Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeWith
        Maybe FilePath
mQueryParams
        RunOptions -> RunOptions
mapOptions
        Tracer IO HydraNodeLog
tracer
        NominalDiffTime
blockTime
        ChainConfig
chainConfig
        FilePath
workDir
        Int
nodeId
        Secret (SigningKey HydraKey)
hydraSigningKey
        [VerificationKey HydraKey]
hydraVerificationKeys
        Map Int HydraNodePorts
nodePorts
        (\HydraClient
c -> Map Int HydraNodePorts -> [HydraClient] -> [Int] -> IO a
startNodes Map Int HydraNodePorts
nodePorts (HydraClient
c HydraClient -> [HydraClient] -> [HydraClient]
forall a. a -> [a] -> [a]
: [HydraClient]
clients) [Int]
rest)

  Timing{NominalDiffTime
blockTime :: NominalDiffTime
$sel:blockTime:Timing :: Timing -> NominalDiffTime
blockTime, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:Timing :: Timing -> ContestationPeriod
contestationPeriod, DepositPeriod
depositPeriod :: DepositPeriod
$sel:depositPeriod:Timing :: Timing -> DepositPeriod
depositPeriod, DepositPeriod
depositActivation :: DepositPeriod
$sel:depositActivation:Timing :: Timing -> DepositPeriod
depositActivation} = Timing
timing

-- * Start / connect to a hydra-node

-- | The three ports a hydra-node binds: API, peer-to-peer listen, and the
-- optional Prometheus monitoring endpoint. Callers allocate these via
-- 'allocateHydraNodePorts' (or pre-allocate a full cluster) and thread them
-- through 'prepareHydraNode' / 'withHydraNode'.
data HydraNodePorts = HydraNodePorts
  { HydraNodePorts -> PortNumber
apiPort :: Network.PortNumber
  , HydraNodePorts -> PortNumber
listenPort :: Network.PortNumber
  , HydraNodePorts -> PortNumber
monitoringPort :: Network.PortNumber
  }
  deriving stock (Int -> HydraNodePorts -> FilePath -> FilePath
[HydraNodePorts] -> FilePath -> FilePath
HydraNodePorts -> FilePath
(Int -> HydraNodePorts -> FilePath -> FilePath)
-> (HydraNodePorts -> FilePath)
-> ([HydraNodePorts] -> FilePath -> FilePath)
-> Show HydraNodePorts
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> HydraNodePorts -> FilePath -> FilePath
showsPrec :: Int -> HydraNodePorts -> FilePath -> FilePath
$cshow :: HydraNodePorts -> FilePath
show :: HydraNodePorts -> FilePath
$cshowList :: [HydraNodePorts] -> FilePath -> FilePath
showList :: [HydraNodePorts] -> FilePath -> FilePath
Show, HydraNodePorts -> HydraNodePorts -> Bool
(HydraNodePorts -> HydraNodePorts -> Bool)
-> (HydraNodePorts -> HydraNodePorts -> Bool) -> Eq HydraNodePorts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HydraNodePorts -> HydraNodePorts -> Bool
== :: HydraNodePorts -> HydraNodePorts -> Bool
$c/= :: HydraNodePorts -> HydraNodePorts -> Bool
/= :: HydraNodePorts -> HydraNodePorts -> Bool
Eq)

-- | Allocate three unused TCP ports from the OS for a single hydra-node.
allocateHydraNodePorts :: IO HydraNodePorts
allocateHydraNodePorts :: IO HydraNodePorts
allocateHydraNodePorts = do
  Map Int HydraNodePorts
m <- [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int
0]
  case Int -> Map Int HydraNodePorts -> Maybe HydraNodePorts
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
0 Map Int HydraNodePorts
m of
    Just HydraNodePorts
ports -> HydraNodePorts -> IO HydraNodePorts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HydraNodePorts
ports
    Maybe HydraNodePorts
Nothing -> FilePath -> IO HydraNodePorts
forall a. HasCallStack => FilePath -> a
Prelude.error FilePath
"allocateHydraNodePorts: empty allocation"

-- | Allocate ports for every node in a cluster up front. The returned map
-- must be passed to every 'prepareHydraNode' / 'withHydraNode' call for
-- nodes in this cluster so peers can be addressed correctly.
--
-- Listen ports are taken via 'randomUnusedTCPPortsWithDerived' so each
-- listen port's derived etcd /client/ port — 'peerPortToClientPort' — is
-- actually held bound at allocation time. That defends against two
-- failure modes: an unrelated process on the host occupying the derived
-- port (which a plain 'randomUnusedTCPPorts' would not catch and which
-- explodes as @EADDRINUSE@ the moment etcd starts), and an unlucky draw
-- where the derived port lands on top of another node's api/monitoring
-- port (which used to make the GRPC client talk to Warp instead of
-- etcd).
--
-- Api and monitoring ports are then acquired in a second batch and
-- checked to be disjoint from both the listen ports and the derived
-- client ports; on collision we retry that second batch.
allocateHydraNodePortsFor :: [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor :: [Int] -> IO (Map Int HydraNodePorts)
allocateHydraNodePortsFor [Int]
nodeIds = do
  [Int]
listenPorts <- (PortNumber -> PortNumber) -> Int -> IO [Int]
randomUnusedTCPPortsWithDerived PortNumber -> PortNumber
peerPortToClientPort Int
n
  let derivedClientPorts :: [Int]
derivedClientPorts =
        [ PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PortNumber -> PortNumber
peerPortToClientPort (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p))
        | Int
p <- [Int]
listenPorts
        ]
      reserved :: [Int]
reserved = [Int]
listenPorts [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int]
derivedClientPorts
  [Int]
apiAndMonPorts <- [Int] -> Int -> IO [Int]
acquireDisjoint [Int]
reserved (Int
20 :: Int)
  let apiPorts :: [Int]
apiPorts = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n [Int]
apiAndMonPorts
      monPorts :: [Int]
monPorts = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
n [Int]
apiAndMonPorts
      assigned :: [HydraNodePorts]
assigned = (Int -> Int -> Int -> HydraNodePorts)
-> [Int] -> [Int] -> [Int] -> [HydraNodePorts]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
Prelude.zipWith3 Int -> Int -> Int -> HydraNodePorts
mkPorts [Int]
apiPorts [Int]
listenPorts [Int]
monPorts
  Map Int HydraNodePorts -> IO (Map Int HydraNodePorts)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Int HydraNodePorts -> IO (Map Int HydraNodePorts))
-> Map Int HydraNodePorts -> IO (Map Int HydraNodePorts)
forall a b. (a -> b) -> a -> b
$ [(Int, HydraNodePorts)] -> Map Int HydraNodePorts
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, HydraNodePorts)] -> Map Int HydraNodePorts)
-> [(Int, HydraNodePorts)] -> Map Int HydraNodePorts
forall a b. (a -> b) -> a -> b
$ [Int] -> [HydraNodePorts] -> [(Int, HydraNodePorts)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
nodeIds [HydraNodePorts]
assigned
 where
  n :: Int
n = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
nodeIds

  acquireDisjoint :: [Int] -> Int -> IO [Int]
  acquireDisjoint :: [Int] -> Int -> IO [Int]
acquireDisjoint [Int]
_ Int
0 =
    FilePath -> IO [Int]
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail
      FilePath
"allocateHydraNodePortsFor: ran out of retries trying to keep the api/monitoring ports disjoint from the derived etcd client ports"
  acquireDisjoint [Int]
reserved Int
remaining = do
    [Int]
ps <- Int -> IO [Int]
randomUnusedTCPPorts (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n)
    if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Int]
ps [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
`List.intersect` [Int]
reserved)
      then [Int] -> IO [Int]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int]
ps
      else [Int] -> Int -> IO [Int]
acquireDisjoint [Int]
reserved (Int
remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

  mkPorts :: Int -> Int -> Int -> HydraNodePorts
  mkPorts :: Int -> Int -> Int -> HydraNodePorts
mkPorts Int
a Int
l Int
m =
    HydraNodePorts
      { $sel:apiPort:HydraNodePorts :: PortNumber
apiPort = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a
      , $sel:listenPort:HydraNodePorts :: PortNumber
listenPort = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l
      , $sel:monitoringPort:HydraNodePorts :: PortNumber
monitoringPort = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m
      }

-- | Process-global cache mapping each @(workDir, nodeId)@ to its allocated
-- ports. The cache exists because restart-style tests (re-running
-- 'withSoloHydraNode' or similar against the same @workDir@) depend on
-- etcd's persistent cluster state, which is keyed by the listen URL. If a
-- restart picked fresh ports, etcd would refuse to start.
{-# NOINLINE soloHydraNodePortsCache #-}
soloHydraNodePortsCache :: IORef (Map (FilePath, Int) HydraNodePorts)
soloHydraNodePortsCache :: IORef (Map (FilePath, Int) HydraNodePorts)
soloHydraNodePortsCache = IO (IORef (Map (FilePath, Int) HydraNodePorts))
-> IORef (Map (FilePath, Int) HydraNodePorts)
forall a. IO a -> a
unsafePerformIO (Map (FilePath, Int) HydraNodePorts
-> IO (IORef (Map (FilePath, Int) HydraNodePorts))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map (FilePath, Int) HydraNodePorts
forall a. Monoid a => a
mempty)

-- | Allocate ports for a single hydra-node, memoizing the result for the
-- given @(workDir, nodeId)@ so that subsequent calls reuse the same ports.
soloHydraNodePortsFor :: FilePath -> Int -> IO HydraNodePorts
soloHydraNodePortsFor :: FilePath -> Int -> IO HydraNodePorts
soloHydraNodePortsFor FilePath
workDir Int
nodeId = do
  Map (FilePath, Int) HydraNodePorts
cache <- IORef (Map (FilePath, Int) HydraNodePorts)
-> IO (Map (FilePath, Int) HydraNodePorts)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map (FilePath, Int) HydraNodePorts)
soloHydraNodePortsCache
  case (FilePath, Int)
-> Map (FilePath, Int) HydraNodePorts -> Maybe HydraNodePorts
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FilePath
workDir, Int
nodeId) Map (FilePath, Int) HydraNodePorts
cache of
    Just HydraNodePorts
ports -> HydraNodePorts -> IO HydraNodePorts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HydraNodePorts
ports
    Maybe HydraNodePorts
Nothing -> do
      HydraNodePorts
ports <- IO HydraNodePorts
allocateHydraNodePorts
      IORef (Map (FilePath, Int) HydraNodePorts)
-> (Map (FilePath, Int) HydraNodePorts
    -> (Map (FilePath, Int) HydraNodePorts, ()))
-> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map (FilePath, Int) HydraNodePorts)
soloHydraNodePortsCache ((Map (FilePath, Int) HydraNodePorts
  -> (Map (FilePath, Int) HydraNodePorts, ()))
 -> IO ())
-> (Map (FilePath, Int) HydraNodePorts
    -> (Map (FilePath, Int) HydraNodePorts, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map (FilePath, Int) HydraNodePorts
m ->
        ((FilePath, Int)
-> HydraNodePorts
-> Map (FilePath, Int) HydraNodePorts
-> Map (FilePath, Int) HydraNodePorts
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (FilePath
workDir, Int
nodeId) HydraNodePorts
ports Map (FilePath, Int) HydraNodePorts
m, ())
      HydraNodePorts -> IO HydraNodePorts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HydraNodePorts
ports

-- | Prepare protocol-parameters to run a hydra-node with given 'ChainConfig' and using the config from
-- config/.
preparePParams ::
  ChainConfig ->
  FilePath ->
  (Aeson.Value -> Aeson.Value) ->
  IO FilePath
preparePParams :: ChainConfig -> FilePath -> (Value -> Value) -> IO FilePath
preparePParams ChainConfig
chainConfig FilePath
stateDir Value -> Value
paramsDecorator = do
  let cardanoLedgerProtocolParametersFile :: FilePath
cardanoLedgerProtocolParametersFile = FilePath
stateDir FilePath -> FilePath -> FilePath
</> FilePath
"protocol-parameters.json"
  case ChainConfig
chainConfig of
    Offline OfflineChainConfig
_ ->
      FilePath -> IO ByteString
readConfigFile FilePath
"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
>>= FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS FilePath
cardanoLedgerProtocolParametersFile
    Cardano CardanoChainConfig{ChainBackendOptions
$sel:chainBackendOptions:CardanoChainConfig :: CardanoChainConfig -> ChainBackendOptions
chainBackendOptions :: ChainBackendOptions
chainBackendOptions} -> do
      Value
protocolParameters <- case ChainBackendOptions
chainBackendOptions of
        Direct DirectOptions{NetworkId
networkId :: NetworkId
$sel:networkId:DirectOptions :: DirectOptions -> NetworkId
networkId, SocketPath
$sel:nodeSocket:DirectOptions :: DirectOptions -> SocketPath
nodeSocket :: SocketPath
nodeSocket} ->
          -- NOTE: This implicitly tests of cardano-cli with hydra-node
          SocketPath -> NetworkId -> IO Value
cliQueryProtocolParameters SocketPath
nodeSocket NetworkId
networkId
        Blockfrost BlockfrostOptions{FilePath
projectPath :: FilePath
$sel:projectPath:BlockfrostOptions :: BlockfrostOptions -> FilePath
projectPath} -> do
          Project
prj <- FilePath -> IO Project
Blockfrost.projectFromFile FilePath
projectPath
          PParams ConwayEra -> Value
forall a. ToJSON a => a -> Value
toJSON (PParams ConwayEra -> Value) -> IO (PParams ConwayEra) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Project
-> BlockfrostClientT IO (PParams ConwayEra)
-> IO (PParams ConwayEra)
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostM Project
prj BlockfrostClientT IO (PParams LedgerEra)
BlockfrostClientT IO (PParams ConwayEra)
forall (m :: * -> *).
MonadIO m =>
BlockfrostClientT m (PParams LedgerEra)
Blockfrost.queryProtocolParameters
      FilePath -> Value -> IO ()
forall a. ToJSON a => FilePath -> a -> IO ()
Aeson.encodeFile FilePath
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)
          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
"utxoCostPerByte" ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Scientific -> Value
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
"treasuryCut" ((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
"minFeeRefScriptCostPerByte" ((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
& Value -> Value
paramsDecorator
  FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
cardanoLedgerProtocolParametersFile

-- | Prepare 'RunOptions' to run a hydra-node with given 'ChainConfig' and using the config from
-- config/.
--
-- The @nodePorts@ map must contain an entry for this @hydraNodeId@ and for
-- every peer this node should connect to. Use 'allocateHydraNodePortsFor' to
-- build it for a cluster, or 'allocateHydraNodePorts' + a singleton map for a
-- standalone node.
prepareHydraNode ::
  HasCallStack =>
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  Map Int HydraNodePorts ->
  (Aeson.Value -> Aeson.Value) ->
  IO RunOptions
prepareHydraNode :: HasCallStack =>
ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys Map Int HydraNodePorts
nodePorts Value -> Value
paramsDecorator = do
  HydraNodePorts{PortNumber
$sel:apiPort:HydraNodePorts :: HydraNodePorts -> PortNumber
apiPort :: PortNumber
apiPort, PortNumber
$sel:listenPort:HydraNodePorts :: HydraNodePorts -> PortNumber
listenPort :: PortNumber
listenPort, PortNumber
$sel:monitoringPort:HydraNodePorts :: HydraNodePorts -> PortNumber
monitoringPort :: PortNumber
monitoringPort} <-
    IO HydraNodePorts
-> (HydraNodePorts -> IO HydraNodePorts)
-> Maybe HydraNodePorts
-> IO HydraNodePorts
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (FilePath -> IO HydraNodePorts
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO HydraNodePorts) -> FilePath -> IO HydraNodePorts
forall a b. (a -> b) -> a -> b
$ FilePath
"prepareHydraNode: no port allocation for node " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId)
      HydraNodePorts -> IO HydraNodePorts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Int -> Map Int HydraNodePorts -> Maybe HydraNodePorts
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
hydraNodeId Map Int HydraNodePorts
nodePorts)
  -- NOTE: AirPlay on MacOS uses 5000 and we must avoid it.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
os FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"darwin") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PortNumber
listenPort PortNumber -> PortNumber -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`Prelude.shouldNotBe` (PortNumber
5_000 :: Network.PortNumber)
  let stateDir :: FilePath
stateDir = FilePath
workDir FilePath -> FilePath -> FilePath
</> FilePath
"state-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
stateDir
  FilePath
cardanoLedgerProtocolParametersFile <- ChainConfig -> FilePath -> (Value -> Value) -> IO FilePath
preparePParams ChainConfig
chainConfig FilePath
stateDir Value -> Value
paramsDecorator
  let hydraSigningKey :: FilePath
hydraSigningKey = FilePath
stateDir FilePath -> FilePath -> FilePath
</> FilePath
"me.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
$ Secret (SigningKey HydraKey)
-> (SigningKey HydraKey -> IO (Either (FileError ()) ()))
-> IO (Either (FileError ()) ())
forall a r. Secret a -> (a -> r) -> r
withSecret Secret (SigningKey HydraKey)
hydraSKey ((SigningKey HydraKey -> IO (Either (FileError ()) ()))
 -> IO (Either (FileError ()) ()))
-> (SigningKey HydraKey -> IO (Either (FileError ()) ()))
-> IO (Either (FileError ()) ())
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 (FilePath -> File Any 'Out
forall content (direction :: FileDirection).
FilePath -> File content direction
File FilePath
hydraSigningKey) Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing
  [FilePath]
hydraVerificationKeys <- [(Int, VerificationKey HydraKey)]
-> ((Int, VerificationKey HydraKey) -> IO FilePath)
-> IO [FilePath]
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 FilePath) -> IO [FilePath])
-> ((Int, VerificationKey HydraKey) -> IO FilePath)
-> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ \(Int
i :: Int, VerificationKey HydraKey
vKey) -> do
    let filepath :: FilePath
filepath = FilePath
stateDir FilePath -> FilePath -> FilePath
</> (FilePath
"other-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
i FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".vk")
    FilePath
filepath FilePath -> IO (Either (FileError ()) ()) -> IO FilePath
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 (FilePath -> File Any 'Out
forall content (direction :: FileDirection).
FilePath -> File content direction
File FilePath
filepath) Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing VerificationKey HydraKey
vKey
  RunOptions -> IO RunOptions
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RunOptions -> IO RunOptions) -> RunOptions -> IO RunOptions
forall a b. (a -> b) -> a -> b
$
    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:listen:RunOptions :: Host
listen = Text -> PortNumber -> Host
Host Text
"0.0.0.0" PortNumber
listenPort
      , $sel:advertise:RunOptions :: Maybe Host
advertise = Maybe Host
forall a. Maybe a
Nothing
      , $sel:peers:RunOptions :: [Host]
peers = [Host]
peersFromMap
      , $sel:apiHost:RunOptions :: IP
apiHost = IP
"0.0.0.0"
      , PortNumber
apiPort :: PortNumber
$sel:apiPort:RunOptions :: PortNumber
apiPort
      , $sel:tlsCertPath:RunOptions :: Maybe FilePath
tlsCertPath = Maybe FilePath
forall a. Maybe a
Nothing
      , $sel:tlsKeyPath:RunOptions :: Maybe FilePath
tlsKeyPath = Maybe FilePath
forall a. Maybe a
Nothing
      , $sel:monitoringPort:RunOptions :: Maybe PortNumber
monitoringPort = PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just PortNumber
monitoringPort
      , FilePath
hydraSigningKey :: FilePath
$sel:hydraSigningKey:RunOptions :: FilePath
hydraSigningKey
      , [FilePath]
hydraVerificationKeys :: [FilePath]
$sel:hydraVerificationKeys:RunOptions :: [FilePath]
hydraVerificationKeys
      , $sel:persistenceDir:RunOptions :: FilePath
persistenceDir = FilePath
stateDir
      , $sel:persistenceRotateAfter:RunOptions :: Maybe (Positive Natural)
persistenceRotateAfter = Maybe (Positive Natural)
forall a. Maybe a
Nothing
      , ChainConfig
chainConfig :: ChainConfig
$sel:chainConfig:RunOptions :: ChainConfig
chainConfig
      , -- NOTE: Use the system etcd to avoid ETXTBSY races where multiple
        -- parallel tests extract the embedded etcd binary into their own
        -- tempdirs and execve while another thread still holds the
        -- write-fd. The dev-shell and CI both provide etcd in $PATH.
        $sel:whichEtcd:RunOptions :: WhichEtcd
whichEtcd = WhichEtcd
SystemEtcd
      , $sel:ledgerConfig:RunOptions :: LedgerConfig
ledgerConfig =
          CardanoLedgerConfig
            { FilePath
cardanoLedgerProtocolParametersFile :: FilePath
$sel:cardanoLedgerProtocolParametersFile:CardanoLedgerConfig :: FilePath
cardanoLedgerProtocolParametersFile
            }
      , $sel:apiTransactionTimeout:RunOptions :: ApiTransactionTimeout
apiTransactionTimeout = ApiTransactionTimeout
100000
      }
 where
  -- NOTE: See comment above about 0.0.0.0 vs 127.0.0.1
  peersFromMap :: [Host]
peersFromMap =
    [ Host{$sel:hostname:Host :: Text
Network.hostname = Text
"0.0.0.0", $sel:port:Host :: PortNumber
Network.port = HydraNodePorts -> PortNumber
listenPort HydraNodePorts
p}
    | (Int
i, HydraNodePorts
p) <- Map Int HydraNodePorts -> [(Int, HydraNodePorts)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int HydraNodePorts
nodePorts
    , Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
hydraNodeId
    ]

-- | Run a hydra-node with given 'RunOptions'.
withPreparedHydraNode ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  FilePath ->
  Int ->
  RunOptions ->
  (HydraClient -> IO a) ->
  IO a
withPreparedHydraNode :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> FilePath -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
withPreparedHydraNode = Maybe FilePath
-> [(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Maybe FilePath
-> [(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
withPreparedHydraNodeWithQuery Maybe FilePath
forall a. Maybe a
Nothing []

-- | Like 'withPreparedHydraNode' but with extra environment entries for the
-- hydra-node process (also inherited by its etcd child). Use this instead of
-- a process-global 'setEnv', which would leak into every other concurrently
-- spawned node.
withPreparedHydraNodeWithEnv ::
  HasCallStack =>
  [(String, String)] ->
  Tracer IO HydraNodeLog ->
  FilePath ->
  Int ->
  RunOptions ->
  (HydraClient -> IO a) ->
  IO a
withPreparedHydraNodeWithEnv :: forall a.
HasCallStack =>
[(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
withPreparedHydraNodeWithEnv = Maybe FilePath
-> [(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Maybe FilePath
-> [(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
withPreparedHydraNodeWithQuery Maybe FilePath
forall a. Maybe a
Nothing

-- | Like 'withPreparedHydraNode' but connecting the API client with the given
-- query string instead of the default "/?history=yes".
withPreparedHydraNodeWithQuery ::
  HasCallStack =>
  Maybe String ->
  [(String, String)] ->
  Tracer IO HydraNodeLog ->
  FilePath ->
  Int ->
  RunOptions ->
  (HydraClient -> IO a) ->
  IO a
withPreparedHydraNodeWithQuery :: forall a.
HasCallStack =>
Maybe FilePath
-> [(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
withPreparedHydraNodeWithQuery Maybe FilePath
mQueryParams [(FilePath, FilePath)]
extraEnv Tracer IO HydraNodeLog
tracer FilePath
workDir Int
hydraNodeId RunOptions
runOptions HydraClient -> IO a
action =
  FilePath -> (Handle -> IO a) -> IO a
forall a. FilePath -> (Handle -> IO a) -> IO a
Prelude.withLogFile FilePath
logFilePath ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
logFileHandle -> do
    ProcessConfig () () Handle -> ProcessConfig () () Handle
applyExtraEnv <-
      if [(FilePath, FilePath)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FilePath, FilePath)]
extraEnv
        then (ProcessConfig () () Handle -> ProcessConfig () () Handle)
-> IO (ProcessConfig () () Handle -> ProcessConfig () () Handle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessConfig () () Handle -> ProcessConfig () () Handle
forall a. a -> a
id
        else do
          [(FilePath, FilePath)]
baseEnv <- IO [(FilePath, FilePath)]
getEnvironment
          (ProcessConfig () () Handle -> ProcessConfig () () Handle)
-> IO (ProcessConfig () () Handle -> ProcessConfig () () Handle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ProcessConfig () () Handle -> ProcessConfig () () Handle)
 -> IO (ProcessConfig () () Handle -> ProcessConfig () () Handle))
-> (ProcessConfig () () Handle -> ProcessConfig () () Handle)
-> IO (ProcessConfig () () Handle -> ProcessConfig () () Handle)
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)]
-> ProcessConfig () () Handle -> ProcessConfig () () Handle
forall stdin stdout stderr.
[(FilePath, FilePath)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnv ([(FilePath, FilePath)]
extraEnv [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. Semigroup a => a -> a -> a
<> ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> [FilePath] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, FilePath)]
extraEnv) (FilePath -> Bool)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
baseEnv)
    -- Benchmark-only hook: HYDRA_NODE_RTS_FLAGS appends '+RTS <flags> -RTS' to
    -- the spawned node (e.g. "-N2 -T"). Deliberately not GHCRTS, which every
    -- GHC binary in the environment would inherit. Unset means byte-identical
    -- spawns.
    [FilePath]
rtsFlags <- [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
forall a. ToString a => a -> FilePath
toString ([Text] -> [FilePath])
-> (FilePath -> [Text]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall t. IsText t "words" => t -> [t]
words (Text -> [Text]) -> (FilePath -> Text) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. ToText a => a -> Text
toText) (Maybe FilePath -> [FilePath])
-> IO (Maybe FilePath) -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
"HYDRA_NODE_RTS_FLAGS"
    let extraArgs :: [FilePath]
extraArgs = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
rtsFlags then [] else [FilePath
"+RTS"] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
rtsFlags [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath
"-RTS"]
    let cmd :: ProcessConfig () () Handle
cmd =
          FilePath -> [FilePath] -> ProcessConfig () () ()
proc FilePath
"hydra-node" (RunOptions -> [FilePath]
toArgs RunOptions
runOptions [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
extraArgs)
            ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
logFileHandle)
            ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () Handle)
-> ProcessConfig () () Handle
forall a b. a -> (a -> b) -> b
& StreamSpec 'STOutput Handle
-> ProcessConfig () () () -> ProcessConfig () () Handle
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
            ProcessConfig () () Handle
-> (ProcessConfig () () Handle -> ProcessConfig () () Handle)
-> ProcessConfig () () Handle
forall a b. a -> (a -> b) -> b
& Bool -> ProcessConfig () () Handle -> ProcessConfig () () Handle
forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCloseFds Bool
True
            ProcessConfig () () Handle
-> (ProcessConfig () () Handle -> ProcessConfig () () Handle)
-> ProcessConfig () () Handle
forall a b. a -> (a -> b) -> b
& ProcessConfig () () Handle -> ProcessConfig () () Handle
applyExtraEnv

    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
$ ProcessConfig () () Handle -> Text
forall b a. (Show a, IsString b) => a -> b
show ProcessConfig () () Handle
cmd

    ProcessConfig () () Handle
-> (Process () () Handle -> IO a) -> IO a
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessTerm ProcessConfig () () Handle
cmd ((Process () () Handle -> IO a) -> IO a)
-> (Process () () Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Process () () Handle
p -> do
      -- NOTE: exit code thread gets cancelled if 'action' terminates first
      (FilePath, IO Void) -> (FilePath, IO a) -> IO (Either Void a)
forall (m :: * -> *) a b.
MonadAsync m =>
(FilePath, m a) -> (FilePath, m b) -> m (Either a b)
raceLabelled
        (FilePath
"collect-check-process-exit-code", Process () () Handle -> IO Void
collectAndCheckExitCode Process () () Handle
p)
        (FilePath
"with-connection-to-node", Tracer IO HydraNodeLog
-> Int
-> Host
-> Maybe PortNumber
-> Maybe FilePath
-> (HydraClient -> IO a)
-> IO a
forall a.
Tracer IO HydraNodeLog
-> Int
-> Host
-> Maybe PortNumber
-> Maybe FilePath
-> (HydraClient -> IO a)
-> IO a
withConnectionToNodeHost Tracer IO HydraNodeLog
tracer Int
hydraNodeId Host
apiAddress Maybe PortNumber
monPort (Maybe FilePath
mQueryParams Maybe FilePath -> Maybe FilePath -> Maybe FilePath
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"/?history=yes") (\HydraClient
client -> HydraClient -> IO a
action HydraClient
client{workDir = Just workDir}))
        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
  apiAddress :: Host
apiAddress =
    case RunOptions
runOptions of
      RunOptions{$sel:apiPort:RunOptions :: RunOptions -> PortNumber
apiPort = PortNumber
p} ->
        Host{$sel:hostname:Host :: Text
Network.hostname = Text
"127.0.0.1", $sel:port:Host :: PortNumber
Network.port = PortNumber
p}

  monPort :: Maybe PortNumber
monPort = case RunOptions
runOptions of
    RunOptions{$sel:monitoringPort:RunOptions :: RunOptions -> Maybe PortNumber
monitoringPort = Maybe PortNumber
mp} -> Maybe PortNumber
mp

  collectAndCheckExitCode :: Process () () Handle -> IO Void
collectAndCheckExitCode Process () () Handle
p = do
    let h :: Handle
h = Process () () Handle -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process () () Handle
p
    Process () () Handle -> IO ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process () () Handle
p IO ExitCode -> (ExitCode -> IO Void) -> IO Void
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ExitCode
ExitSuccess -> FilePath -> IO Void
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure FilePath
"hydra-node stopped early"
      ExitFailure Int
ec -> do
        ByteString
err <- Handle -> IO ByteString
hGetContents Handle
h
        FilePath -> IO Void
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO Void) -> (Text -> FilePath) -> Text -> IO Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> IO Void) -> Text -> IO Void
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines
            [ Text
"hydra-node (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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") exited with failure code: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
ec
            , ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
err
            ]

  logFilePath :: FilePath
logFilePath = FilePath
workDir FilePath -> FilePath -> FilePath
</> FilePath
"logs" FilePath -> FilePath -> FilePath
</> FilePath
"hydra-node-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Int
hydraNodeId FilePath -> FilePath -> FilePath
<.> FilePath
"log"

-- | Convenience: run a single hydra-node with no peers and freshly
-- allocated dynamic ports. Equivalent to 'withHydraNode' with a singleton
-- port map.
withSoloHydraNode ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  NominalDiffTime ->
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  (HydraClient -> IO a) ->
  IO a
withSoloHydraNode :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNode Tracer IO HydraNodeLog
tracer NominalDiffTime
blockTime ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys HydraClient -> IO a
action = do
  HydraNodePorts
ports <- FilePath -> Int -> IO HydraNodePorts
soloHydraNodePortsFor FilePath
workDir Int
hydraNodeId
  Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode Tracer IO HydraNodeLog
tracer NominalDiffTime
blockTime ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys (Int -> HydraNodePorts -> Map Int HydraNodePorts
forall k a. k -> a -> Map k a
Map.singleton Int
hydraNodeId HydraNodePorts
ports) HydraClient -> IO a
action

-- | Convenience: 'withUnsyncedHydraNode' for a single node with freshly
-- allocated dynamic ports.
withUnsyncedSoloHydraNode ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  (HydraClient -> IO a) ->
  IO a
withUnsyncedSoloHydraNode :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withUnsyncedSoloHydraNode Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys HydraClient -> IO a
action = do
  HydraNodePorts
ports <- FilePath -> Int -> IO HydraNodePorts
soloHydraNodePortsFor FilePath
workDir Int
hydraNodeId
  Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys (Int -> HydraNodePorts -> Map Int HydraNodePorts
forall k a. k -> a -> Map k a
Map.singleton Int
hydraNodeId HydraNodePorts
ports) HydraClient -> IO a
action

-- | Convenience: 'withHydraNodeCatchingUp' for a single node with freshly
-- allocated dynamic ports.
withSoloHydraNodeCatchingUp ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  (HydraClient -> IO a) ->
  IO a
withSoloHydraNodeCatchingUp :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> (HydraClient -> IO a)
-> IO a
withSoloHydraNodeCatchingUp Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys HydraClient -> IO a
action = do
  HydraNodePorts
ports <- FilePath -> Int -> IO HydraNodePorts
soloHydraNodePortsFor FilePath
workDir Int
hydraNodeId
  Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeCatchingUp Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys (Int -> HydraNodePorts -> Map Int HydraNodePorts
forall k a. k -> a -> Map k a
Map.singleton Int
hydraNodeId HydraNodePorts
ports) HydraClient -> IO a
action

-- | Run a hydra-node just like `withHydraNode`; but before running any
-- action, observe a `Greetings` message with the node in sync first. NOTE
-- that importantly, any messages seen BEFORE we observe this will be lost;
-- i.e. unobservable by subsequent `waitFor`s.
--
-- See 'prepareHydraNode' for how to build the port map.
withHydraNode ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  NominalDiffTime ->
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  Map Int HydraNodePorts ->
  (HydraClient -> IO a) ->
  IO a
withHydraNode :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNode = Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeWith Maybe FilePath
forall a. Maybe a
Nothing RunOptions -> RunOptions
forall a. a -> a
id

-- | Like 'withHydraNode' but connecting the API client with the given query
-- string instead of the default "/?history=yes", and adjusting the node's
-- 'RunOptions' before it is started.
withHydraNodeWith ::
  HasCallStack =>
  Maybe String ->
  (RunOptions -> RunOptions) ->
  Tracer IO HydraNodeLog ->
  NominalDiffTime ->
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  Map Int HydraNodePorts ->
  (HydraClient -> IO a) ->
  IO a
withHydraNodeWith :: forall a.
HasCallStack =>
Maybe FilePath
-> (RunOptions -> RunOptions)
-> Tracer IO HydraNodeLog
-> NominalDiffTime
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeWith Maybe FilePath
mQueryParams RunOptions -> RunOptions
mapOptions Tracer IO HydraNodeLog
tracer NominalDiffTime
blockTime ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys Map Int HydraNodePorts
nodePorts HydraClient -> IO a
action = do
  RunOptions
opts <- HasCallStack =>
ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys Map Int HydraNodePorts
nodePorts Value -> Value
forall a. a -> a
id
  Maybe FilePath
-> [(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
forall a.
HasCallStack =>
Maybe FilePath
-> [(FilePath, FilePath)]
-> Tracer IO HydraNodeLog
-> FilePath
-> Int
-> RunOptions
-> (HydraClient -> IO a)
-> IO a
withPreparedHydraNodeWithQuery Maybe FilePath
mQueryParams [] Tracer IO HydraNodeLog
tracer FilePath
workDir Int
hydraNodeId (RunOptions -> RunOptions
mapOptions RunOptions
opts) HydraClient -> IO a
action'
 where
  waitTime :: NominalDiffTime
waitTime = NominalDiffTime
blockTime NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
5
  action' :: HydraClient -> IO a
action' HydraClient
client = do
    HasCallStack => NominalDiffTime -> [HydraClient] -> IO ()
NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesSynced NominalDiffTime
waitTime [HydraClient
client]
    HydraClient -> IO a
action HydraClient
client

-- | Run a hydra-node with given 'ChainConfig' and using the config from
-- config/, but, importantly, do NOT wait for the sync status to be reported.
withUnsyncedHydraNode ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  Map Int HydraNodePorts ->
  (HydraClient -> IO a) ->
  IO a
withUnsyncedHydraNode :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withUnsyncedHydraNode Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys Map Int HydraNodePorts
nodePorts HydraClient -> IO a
action = do
  RunOptions
opts <- HasCallStack =>
ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys Map Int HydraNodePorts
nodePorts Value -> Value
forall a. a -> a
id
  Tracer IO HydraNodeLog
-> FilePath -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> FilePath -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
withPreparedHydraNode Tracer IO HydraNodeLog
tracer FilePath
workDir Int
hydraNodeId RunOptions
opts HydraClient -> IO a
action

-- | Run a hydra-node with given 'ChainConfig' and using the config from
-- config and catching up with chain backend/.
withHydraNodeCatchingUp ::
  HasCallStack =>
  Tracer IO HydraNodeLog ->
  ChainConfig ->
  FilePath ->
  Int ->
  Secret (SigningKey HydraKey) ->
  [VerificationKey HydraKey] ->
  Map Int HydraNodePorts ->
  (HydraClient -> IO a) ->
  IO a
withHydraNodeCatchingUp :: forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (HydraClient -> IO a)
-> IO a
withHydraNodeCatchingUp Tracer IO HydraNodeLog
tracer ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys Map Int HydraNodePorts
nodePorts HydraClient -> IO a
action = do
  RunOptions
opts <- HasCallStack =>
ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
ChainConfig
-> FilePath
-> Int
-> Secret (SigningKey HydraKey)
-> [VerificationKey HydraKey]
-> Map Int HydraNodePorts
-> (Value -> Value)
-> IO RunOptions
prepareHydraNode ChainConfig
chainConfig FilePath
workDir Int
hydraNodeId Secret (SigningKey HydraKey)
hydraSKey [VerificationKey HydraKey]
hydraVKeys Map Int HydraNodePorts
nodePorts Value -> Value
forall a. a -> a
id
  Tracer IO HydraNodeLog
-> FilePath -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
forall a.
HasCallStack =>
Tracer IO HydraNodeLog
-> FilePath -> Int -> RunOptions -> (HydraClient -> IO a) -> IO a
withPreparedHydraNode Tracer IO HydraNodeLog
tracer FilePath
workDir Int
hydraNodeId RunOptions
opts HydraClient -> IO a
action

withConnectionToNode :: forall a. Tracer IO HydraNodeLog -> Int -> Host -> Maybe Network.PortNumber -> (HydraClient -> IO a) -> IO a
withConnectionToNode :: forall a.
Tracer IO HydraNodeLog
-> Int -> Host -> Maybe PortNumber -> (HydraClient -> IO a) -> IO a
withConnectionToNode Tracer IO HydraNodeLog
tracer Int
hydraNodeId Host
apiHost Maybe PortNumber
monitoringPort =
  Tracer IO HydraNodeLog
-> Int
-> Host
-> Maybe PortNumber
-> Maybe FilePath
-> (HydraClient -> IO a)
-> IO a
forall a.
Tracer IO HydraNodeLog
-> Int
-> Host
-> Maybe PortNumber
-> Maybe FilePath
-> (HydraClient -> IO a)
-> IO a
withConnectionToNodeHost Tracer IO HydraNodeLog
tracer Int
hydraNodeId Host
apiHost Maybe PortNumber
monitoringPort (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"/?history=yes")

withConnectionToNodeHost :: forall a. Tracer IO HydraNodeLog -> Int -> Host -> Maybe Network.PortNumber -> Maybe String -> (HydraClient -> IO a) -> IO a
withConnectionToNodeHost :: forall a.
Tracer IO HydraNodeLog
-> Int
-> Host
-> Maybe PortNumber
-> Maybe FilePath
-> (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 PortNumber
monitoringPort Maybe FilePath
mQueryParams HydraClient -> IO a
action = do
  IORef Bool
connectedOnce <- Bool -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Bool
False
  (Int
retries, DiffTime
delay) <-
    IO HydraTestnet
Prelude.getHydraNetwork IO HydraTestnet
-> (HydraTestnet -> IO (Int, DiffTime)) -> IO (Int, DiffTime)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      HydraTestnet
Prelude.LocalDevnet -> (Int, DiffTime) -> IO (Int, DiffTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
200, DiffTime
0.1)
      HydraTestnet
Prelude.Mainnet -> (Int, DiffTime) -> IO (Int, DiffTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
7200, DiffTime
1)
      HydraTestnet
_ -> (Int, DiffTime) -> IO (Int, DiffTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
300, DiffTime
1)
  IORef Bool -> Int -> DiffTime -> IO a
tryConnect IORef Bool
connectedOnce (Int
retries :: Int) DiffTime
delay
 where
  tryConnect :: IORef Bool -> Int -> DiffTime -> IO a
tryConnect IORef Bool
connectedOnce Int
n DiffTime
delay
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = FilePath -> IO a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
FilePath -> m a
failure (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"Timed out waiting for connection to hydra-node " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
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
delay 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 -> DiffTime -> IO a
tryConnect IORef Bool
connectedOnce (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) DiffTime
delay
              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)
                    ]

  queryParams :: FilePath
queryParams = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"/" Maybe FilePath
mQueryParams

  -- NOTE: Derived from the query string, so callers opt into CBOR by adding
  -- @encoding=cbor@ to their query params.
  apiEncoding :: ApiEncoding
apiEncoding
    | FilePath
"encoding=cbor" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` FilePath
queryParams = ApiEncoding
CborEncoding
    | Bool
otherwise = ApiEncoding
JsonEncoding

  doConnect :: IORef Bool -> IO a
doConnect IORef Bool
connectedOnce = FilePath -> Int -> FilePath -> ClientApp a -> IO a
forall a. FilePath -> Int -> FilePath -> ClientApp a -> IO a
runClient (Text -> FilePath
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) FilePath
queryParams (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, Maybe PortNumber
$sel:monitoringPort:HydraClient :: Maybe PortNumber
monitoringPort :: Maybe PortNumber
monitoringPort, Connection
$sel:connection:HydraClient :: Connection
connection :: Connection
connection, Tracer IO HydraNodeLog
$sel:tracer:HydraClient :: Tracer IO HydraNodeLog
tracer :: Tracer IO HydraNodeLog
tracer, ApiEncoding
$sel:apiEncoding:HydraClient :: ApiEncoding
apiEncoding :: ApiEncoding
apiEncoding, $sel:workDir:HydraClient :: Maybe FilePath
workDir = Maybe FilePath
forall a. Maybe a
Nothing}
      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

waitForNodesConnected :: Tracer IO HydraNodeLog -> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesConnected :: Tracer IO HydraNodeLog
-> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesConnected Tracer IO HydraNodeLog
tracer NominalDiffTime
delay NonEmpty HydraClient
clients =
  HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
tracer NominalDiffTime
delay (NonEmpty HydraClient -> [HydraClient]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty HydraClient
clients) (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text -> [Pair] -> Value
output Text
"NetworkConnected" []

waitForNodesDisconnected :: Tracer IO HydraNodeLog -> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesDisconnected :: Tracer IO HydraNodeLog
-> NominalDiffTime -> NonEmpty HydraClient -> IO ()
waitForNodesDisconnected Tracer IO HydraNodeLog
tracer NominalDiffTime
delay NonEmpty HydraClient
clients =
  HasCallStack =>
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
Tracer IO HydraNodeLog
-> NominalDiffTime -> [HydraClient] -> Value -> IO ()
waitFor Tracer IO HydraNodeLog
tracer NominalDiffTime
delay (NonEmpty HydraClient -> [HydraClient]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty HydraClient
clients) (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text -> [Pair] -> Value
output Text
"NetworkDisconnected" []

waitForNodesSynced :: HasCallStack => NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesSynced :: HasCallStack => NominalDiffTime -> [HydraClient] -> IO ()
waitForNodesSynced NominalDiffTime
delay [HydraClient]
clients = do
  -- Wait for Greetings from each client. Greetings is always sent AFTER
  -- historical replay, so receiving it means we've consumed all historical
  -- messages. This prevents tests from matching on historical HeadIsOpen or
  -- NodeSynced messages from previous runs when using a persistent state dir.
  [Text]
syncedStatuses <- [HydraClient] -> (HydraClient -> IO Text) -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, MonadAsync m) =>
t a -> (a -> m b) -> m (t b)
forConcurrently ([HydraClient] -> [HydraClient]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [HydraClient]
clients) ((HydraClient -> IO Text) -> IO [Text])
-> (HydraClient -> IO Text) -> IO [Text]
forall a b. (a -> b) -> a -> b
$ \HydraClient
client ->
    NominalDiffTime -> HydraClient -> (Value -> Maybe Text) -> IO Text
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
delay HydraClient
client ((Value -> Maybe Text) -> IO Text)
-> (Value -> Maybe Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"tag" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
"Greetings"
      Value
v Value -> Getting (First Text) Value Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"chainSyncedStatus" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String
  -- If any node is still catching up, additionally wait for a fresh NodeSynced
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"CatchingUp" Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
syncedStatuses) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [HydraClient] -> (HydraClient -> IO ()) -> IO ()
forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
forConcurrently_ ([HydraClient] -> [HydraClient]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [HydraClient]
clients) ((HydraClient -> IO ()) -> IO ())
-> (HydraClient -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HydraClient
client ->
      NominalDiffTime -> HydraClient -> (Value -> Maybe ()) -> IO ()
forall a.
HasCallStack =>
NominalDiffTime -> HydraClient -> (Value -> Maybe a) -> IO a
waitMatch NominalDiffTime
delay HydraClient
client ((Value -> Maybe ()) -> IO ()) -> (Value -> Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"tag" Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
"NodeSynced"