module Hydra.Logging.MonitoringSpec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Data.Text qualified as Text

import Control.Tracer.JSON (Tracer, nullTracer, traceWith)
import GHC.Stats (getRTSStatsEnabled)
import Hydra.API.ClientInput (ClientInput (NewTx))
import Hydra.API.ServerOutput (ClientMessage (RejectedInputBecauseBroadcastStalled))
import Hydra.HeadLogic.Outcome (Effect (ClientEffect), Outcome (..), StateChanged (..))
import Hydra.HeadLogicSpec (receiveMessage, testSnapshot)
import Hydra.Ledger.Simple (SimpleTx)
import Hydra.Logging.Messages (HydraLog (Node))
import Hydra.Logging.Monitoring
import Hydra.Network (Host (Host), StallReason (..))
import Hydra.Network.Message (Message (ReqTx))
import Hydra.Node (HydraNodeLog (..))

-- import Network.Socket (PortNumber(PortNumber))
import Network.HTTP.Req (GET (..), NoReqBody (..), bsResponse, defaultHttpConfig, http, port, req, responseBody, runReq, (/:))
import Test.Hydra.Ledger.Simple (aValidTx, utxoRefs)
import Test.Hydra.Tx.Fixture (alice, testHeadId)
import Test.Network.Ports (randomUnusedTCPPorts)

spec :: Spec
spec :: Spec
spec = do
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"records snapshot round and tx confirmation times on the normal signing path" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
3 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Int
p] <- Int -> IO [Int]
randomUnusedTCPPorts Int
1
      Maybe PortNumber
-> Tracer IO (HydraLog SimpleTx)
-> (Tracer IO (HydraLog SimpleTx) -> IO ())
-> IO ()
forall (m :: * -> *) tx.
(MonadIO m, MonadAsync m, IsTx tx, MonadMonotonicTime m,
 MonadTime m, MonadLabelledSTM m) =>
Maybe PortNumber
-> Tracer m (HydraLog tx)
-> (Tracer m (HydraLog tx) -> m ())
-> m ()
withMonitoring (PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just (PortNumber -> Maybe PortNumber) -> PortNumber -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p) Tracer IO (HydraLog SimpleTx)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer ((Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraLog SimpleTx)
tracer -> do
        let tx :: SimpleTx
tx = Integer -> SimpleTx
aValidTx Integer
42
            snapshot :: Snapshot SimpleTx
snapshot = SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
1 [SimpleTx
tx] ([Integer] -> UTxOType SimpleTx
utxoRefs [Integer
1])
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Word64 -> Input SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Word64 -> Input tx -> HydraNodeLog tx
BeginInput Party
alice Word64
0 (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
tx)))
        DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [Snapshot SimpleTx
-> Seq SimpleTx
-> Maybe (TxIdType SimpleTx)
-> StateChanged SimpleTx
forall tx.
Snapshot tx -> Seq tx -> Maybe (TxIdType tx) -> StateChanged tx
SnapshotRequested Snapshot SimpleTx
snapshot Seq SimpleTx
forall a. Monoid a => a
mempty Maybe Integer
Maybe (TxIdType SimpleTx)
forall a. Maybe a
Nothing] [Effect SimpleTx]
forall a. Monoid a => a
mempty))
        DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1
        -- The normal signing path confirms without a snapshot in the event
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [HeadId
-> Maybe (Snapshot SimpleTx)
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall tx.
HeadId
-> Maybe (Snapshot tx)
-> MultiSignature (Snapshot tx)
-> StateChanged tx
SnapshotConfirmed HeadId
testHeadId Maybe (Snapshot SimpleTx)
forall a. Maybe a
Nothing MultiSignature (Snapshot SimpleTx)
forall a. Monoid a => a
mempty] [Effect SimpleTx]
forall a. Monoid a => a
mempty))

        [Text]
metrics <- Text -> [Text]
Text.lines (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Text
scrapeMetrics Int
p

        [Text]
metrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_confirmed_tx  1"]
        [Text]
metrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_snapshot_confirmation_time_ms_bucket{le=\"1000.0\"} 1.0"]
        [Text]
metrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_tx_confirmation_time_ms_bucket{le=\"1000.0\"} 1.0"]

  -- These names are a public interface: Prometheus scrapes them, and several
  -- are referenced by the dashboards under demo/grafana, so dropping or
  -- renaming one breaks operators without breaking any other test. All are
  -- registered when monitoring starts, so a scrape carries every one of them
  -- before anything has been observed.
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"registers every documented metric on start up" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
10 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Int
p] <- Int -> IO [Int]
randomUnusedTCPPorts Int
1
      Maybe PortNumber
-> Tracer IO (HydraLog SimpleTx)
-> (Tracer IO (HydraLog SimpleTx) -> IO ())
-> IO ()
forall (m :: * -> *) tx.
(MonadIO m, MonadAsync m, IsTx tx, MonadMonotonicTime m,
 MonadTime m, MonadLabelledSTM m) =>
Maybe PortNumber
-> Tracer m (HydraLog tx)
-> (Tracer m (HydraLog tx) -> m ())
-> m ()
withMonitoring (PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just (PortNumber -> Maybe PortNumber) -> PortNumber -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p) Tracer IO (HydraLog SimpleTx)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer ((Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Tracer IO (HydraLog SimpleTx)
_ :: Tracer IO (HydraLog SimpleTx)) -> do
        [Text]
scraped <- Text -> [Text]
scrapedMetricNames (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Text
scrapeMetrics Int
p
        (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Text]
scraped) [Text]
protocolMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` []
        -- The RTS gauges are registered only when the process runs with
        -- '+RTS -T', which this suite does not, so they are expected absent
        -- here and present anywhere that does.
        Bool
rtsEnabled <- IO Bool
getRTSStatsEnabled
        (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
scraped) [Text]
rtsMetrics
          [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (if Bool
rtsEnabled then [Text]
rtsMetrics else [])

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a stalled broadcast, its backlog and what it refused" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- The metrics an operator diagnosing GHSA-3mmr-q43p-g6p2 reads: whether
    -- the hand-off is stalled, how much it holds and for how long, and how
    -- many client inputs that cost.
    NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
3 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Int
p] <- Int -> IO [Int]
randomUnusedTCPPorts Int
1
      Maybe PortNumber
-> Tracer IO (HydraLog SimpleTx)
-> (Tracer IO (HydraLog SimpleTx) -> IO ())
-> IO ()
forall (m :: * -> *) tx.
(MonadIO m, MonadAsync m, IsTx tx, MonadMonotonicTime m,
 MonadTime m, MonadLabelledSTM m) =>
Maybe PortNumber
-> Tracer m (HydraLog tx)
-> (Tracer m (HydraLog tx) -> m ())
-> m ()
withMonitoring (PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just (PortNumber -> Maybe PortNumber) -> PortNumber -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p) Tracer IO (HydraLog SimpleTx)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer ((Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraLog SimpleTx)
tracer -> do
        let scrape :: IO [Text]
scrape = Text -> [Text]
Text.lines (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Text
scrapeMetrics Int
p

        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Natural -> DiffTime -> HydraNodeLog SimpleTx
forall tx. Natural -> DiffTime -> HydraNodeLog tx
BroadcastBacklog Natural
7 DiffTime
4)
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [Natural -> StallReason -> StateChanged SimpleTx
forall tx. Natural -> StallReason -> StateChanged tx
NetworkBroadcastStalled Natural
7 StallReason
NoProgress] [Effect SimpleTx]
forall a. Monoid a => a
mempty))
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraLog SimpleTx -> IO ())
-> (Outcome SimpleTx -> HydraLog SimpleTx)
-> Outcome SimpleTx
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> (Outcome SimpleTx -> HydraNodeLog SimpleTx)
-> Outcome SimpleTx
-> HydraLog SimpleTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice (Outcome SimpleTx -> IO ()) -> Outcome SimpleTx -> IO ()
forall a b. (a -> b) -> a -> b
$
          [StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [StateChanged SimpleTx]
forall a. Monoid a => a
mempty [ClientMessage SimpleTx -> Effect SimpleTx
forall tx. ClientMessage tx -> Effect tx
ClientEffect (ClientInput SimpleTx
-> Natural -> StallReason -> ClientMessage SimpleTx
forall tx.
ClientInput tx -> Natural -> StallReason -> ClientMessage tx
RejectedInputBecauseBroadcastStalled (SimpleTx -> ClientInput SimpleTx
forall tx. tx -> ClientInput tx
NewTx (Integer -> SimpleTx
aValidTx Integer
42)) Natural
7 StallReason
NoProgress)]

        [Text]
stalledMetrics <- IO [Text]
scrape
        [Text]
stalledMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled  1.0"]
        [Text]
stalledMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_pending_broadcasts  7.0"]
        [Text]
stalledMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_no_progress_seconds  4.0"]
        [Text]
stalledMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_inputs_refused_broadcast_stalled  1"]
        -- Which of the two conditions it is, so an operator can tell an
        -- unreachable network from one merely being outrun (review: vrom911).
        [Text]
stalledMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled_no_progress  1.0"]
        [Text]
stalledMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled_backlog_full  0.0"]

        -- The other cause must move the other gauge, and only that one.
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [Natural -> StallReason -> StateChanged SimpleTx
forall tx. Natural -> StallReason -> StateChanged tx
NetworkBroadcastStalled Natural
1000 StallReason
BacklogFull] [Effect SimpleTx]
forall a. Monoid a => a
mempty))
        [Text]
backlogMetrics <- IO [Text]
scrape
        [Text]
backlogMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled  1.0"]
        [Text]
backlogMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled_no_progress  0.0"]
        [Text]
backlogMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled_backlog_full  1.0"]

        -- Draining again must take them all back down, or a cleared stall
        -- looks like a current one forever.
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Natural -> DiffTime -> HydraNodeLog SimpleTx
forall tx. Natural -> DiffTime -> HydraNodeLog tx
BroadcastBacklog Natural
0 DiffTime
0)
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [StateChanged SimpleTx
forall tx. StateChanged tx
NetworkBroadcastResumed] [Effect SimpleTx]
forall a. Monoid a => a
mempty))

        [Text]
resumedMetrics <- IO [Text]
scrape
        [Text]
resumedMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled  0.0"]
        [Text]
resumedMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled_no_progress  0.0"]
        [Text]
resumedMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_stalled_backlog_full  0.0"]
        [Text]
resumedMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_pending_broadcasts  0.0"]
        [Text]
resumedMetrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_broadcast_no_progress_seconds  0.0"]

  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"provides prometheus metrics from traces" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
3 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Int
p] <- Int -> IO [Int]
randomUnusedTCPPorts Int
1
      Maybe PortNumber
-> Tracer IO (HydraLog SimpleTx)
-> (Tracer IO (HydraLog SimpleTx) -> IO ())
-> IO ()
forall (m :: * -> *) tx.
(MonadIO m, MonadAsync m, IsTx tx, MonadMonotonicTime m,
 MonadTime m, MonadLabelledSTM m) =>
Maybe PortNumber
-> Tracer m (HydraLog tx)
-> (Tracer m (HydraLog tx) -> m ())
-> m ()
withMonitoring (PortNumber -> Maybe PortNumber
forall a. a -> Maybe a
Just (PortNumber -> Maybe PortNumber) -> PortNumber -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p) Tracer IO (HydraLog SimpleTx)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer ((Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ())
-> (Tracer IO (HydraLog SimpleTx) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO (HydraLog SimpleTx)
tracer -> do
        let tx1 :: SimpleTx
tx1 = Integer -> SimpleTx
aValidTx Integer
42
        let tx2 :: SimpleTx
tx2 = Integer -> SimpleTx
aValidTx Integer
43
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Word64 -> Input SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Word64 -> Input tx -> HydraNodeLog tx
BeginInput Party
alice Word64
0 (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
tx1)))
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Word64 -> Input SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Word64 -> Input tx -> HydraNodeLog tx
BeginInput Party
alice Word64
1 (Message SimpleTx -> Input SimpleTx
forall tx. Message tx -> Input tx
receiveMessage (SimpleTx -> Message SimpleTx
forall tx. tx -> Message tx
ReqTx SimpleTx
tx2)))
        DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.1
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [HeadId
-> Maybe (Snapshot SimpleTx)
-> MultiSignature (Snapshot SimpleTx)
-> StateChanged SimpleTx
forall tx.
HeadId
-> Maybe (Snapshot tx)
-> MultiSignature (Snapshot tx)
-> StateChanged tx
SnapshotConfirmed HeadId
testHeadId (Snapshot SimpleTx -> Maybe (Snapshot SimpleTx)
forall a. a -> Maybe a
Just (SnapshotNumber
-> SnapshotVersion
-> [SimpleTx]
-> UTxOType SimpleTx
-> Snapshot SimpleTx
forall tx.
IsTx tx =>
SnapshotNumber
-> SnapshotVersion -> [tx] -> UTxOType tx -> Snapshot tx
testSnapshot SnapshotNumber
1 SnapshotVersion
1 [SimpleTx
tx2, SimpleTx
tx1] ([Integer] -> UTxOType SimpleTx
utxoRefs [Integer
1]))) MultiSignature (Snapshot SimpleTx)
forall a. Monoid a => a
mempty] [Effect SimpleTx]
forall a. Monoid a => a
mempty))
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [Host -> StateChanged SimpleTx
forall tx. Host -> StateChanged tx
PeerConnected (Text -> PortNumber -> Host
Host Text
"a" PortNumber
1)] [Effect SimpleTx]
forall a. Monoid a => a
mempty))
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [Host -> StateChanged SimpleTx
forall tx. Host -> StateChanged tx
PeerConnected (Text -> PortNumber -> Host
Host Text
"b" PortNumber
2)] [Effect SimpleTx]
forall a. Monoid a => a
mempty))
        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [Host -> StateChanged SimpleTx
forall tx. Host -> StateChanged tx
PeerDisconnected (Text -> PortNumber -> Host
Host Text
"b" PortNumber
2)] [Effect SimpleTx]
forall a. Monoid a => a
mempty))

        [Text]
metrics <- Text -> [Text]
Text.lines (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Text
scrapeMetrics Int
p

        [Text]
metrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_confirmed_tx  2"]
        [Text]
metrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_peers_connected  1.0"]
        [Text]
metrics [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_tx_confirmation_time_ms_bucket{le=\"1000.0\"} 2.0"]

        Tracer IO (HydraLog SimpleTx) -> HydraLog SimpleTx -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (HydraLog SimpleTx)
tracer (HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall tx. HydraNodeLog tx -> HydraLog tx
Node (HydraNodeLog SimpleTx -> HydraLog SimpleTx)
-> HydraNodeLog SimpleTx -> HydraLog SimpleTx
forall a b. (a -> b) -> a -> b
$ Party -> Outcome SimpleTx -> HydraNodeLog SimpleTx
forall tx. Party -> Outcome tx -> HydraNodeLog tx
LogicOutcome Party
alice ([StateChanged SimpleTx] -> [Effect SimpleTx] -> Outcome SimpleTx
forall tx. [StateChanged tx] -> [Effect tx] -> Outcome tx
Continue [StateChanged SimpleTx
forall tx. StateChanged tx
NetworkDisconnected] [Effect SimpleTx]
forall a. Monoid a => a
mempty))

        [Text]
m <- Text -> [Text]
Text.lines (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Text
scrapeMetrics Int
p

        [Text]
m [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Text
"hydra_head_peers_connected  0.0"]

-- | The metrics 'withMonitoring' always registers.
protocolMetrics :: [Text]
protocolMetrics :: [Text]
protocolMetrics =
  [ Text
"hydra_head_inputs"
  , Text
"hydra_head_requested_tx"
  , Text
"hydra_head_confirmed_tx"
  , Text
"hydra_head_tx_confirmation_time_ms"
  , Text
"hydra_head_snapshot_confirmation_time_ms"
  , Text
"hydra_head_peers_connected"
  , Text
"hydra_chain_drift_seconds"
  , Text
"hydra_chain_last_block_timestamp_seconds"
  ]

-- | Registered only when the RTS collects statistics, see 'registerRtsMetrics'.
rtsMetrics :: [Text]
rtsMetrics :: [Text]
rtsMetrics =
  [ Text
"hydra_rts_allocated_bytes"
  , Text
"hydra_rts_mutator_cpu_seconds"
  , Text
"hydra_rts_gc_cpu_seconds"
  , Text
"hydra_rts_max_live_bytes"
  , Text
"hydra_rts_cumulative_live_bytes"
  , Text
"hydra_rts_major_gcs"
  ]

-- | The metric names a scrape actually exposes: the identifier starting each
-- sample line, with the suffixes Prometheus appends to a histogram removed.
--
-- Matching whole names rather than substrings is the point: renaming a counter
-- to, say, @hydra_head_inputs_total@ has to be caught, and the old name is a
-- prefix of the new one.
scrapedMetricNames :: Text -> [Text]
scrapedMetricNames :: Text -> [Text]
scrapedMetricNames Text
body =
  [Text] -> [Text]
forall a. Ord a => [a] -> [a]
ordNub
    [ Text -> Text
stripHistogramSuffix Text
ident
    | Text
line <- Text -> [Text]
Text.lines Text
body
    , Bool -> Bool
not (Text
"#" Text -> Text -> Bool
`Text.isPrefixOf` Text
line)
    , let ident :: Text
ident = (Char -> Bool) -> Text -> Text
Text.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{') Text
line
    , Bool -> Bool
not (Text -> Bool
Text.null Text
ident)
    ]
 where
  stripHistogramSuffix :: Text -> Text
stripHistogramSuffix Text
name =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
name (Maybe Text -> Text)
-> ([Maybe Text] -> Maybe Text) -> [Maybe Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe Text] -> Text) -> [Maybe Text] -> Text
forall a b. (a -> b) -> a -> b
$
      [Text -> Text -> Maybe Text
Text.stripSuffix Text
suffix Text
name | Text
suffix <- [Text
"_bucket", Text
"_sum", Text
"_count"]]

-- | 'withMonitoring' forks its server and returns immediately, so a scrape can
-- arrive before the socket is listening.
scrapeMetrics :: Int -> IO Text
scrapeMetrics :: Int -> IO Text
scrapeMetrics Int
p = Int -> IO Text
go (Int
100 :: Int)
 where
  go :: Int -> IO Text
go Int
n =
    IO Text -> IO (Either SomeException Text)
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 Text
scrape IO (Either SomeException Text)
-> (Either SomeException Text -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right Text
body -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
body
      Left (SomeException
e :: SomeException)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> SomeException -> IO Text
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
        | Bool
otherwise -> DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.05 IO () -> IO Text -> IO Text
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Text
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

  scrape :: IO Text
scrape =
    ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8
      (ByteString -> Text)
-> (BsResponse -> ByteString) -> BsResponse -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BsResponse -> ByteString
BsResponse -> HttpResponseBody BsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody
      (BsResponse -> Text) -> IO BsResponse -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq @IO HttpConfig
defaultHttpConfig (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 GET
GET (Text -> Url 'Http
http Text
"localhost" Url 'Http -> Text -> Url 'Http
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"metrics") NoReqBody
NoReqBody Proxy BsResponse
bsResponse (Int -> Option 'Http
forall (scheme :: Scheme). Int -> Option scheme
port Int
p))