{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Consistency checks over the 'MetaTrace' instances.
--
-- These need no trace values: everything here is derived from 'allNamespaces'
-- and the namespace-indexed methods. That makes them cheap enough to run over
-- every traced type. What they check is that every namespace in
-- 'allNamespaces' is well formed: it is non-empty and unique, and it has a
-- severity (a missing one silently makes the message unconfigurable), a
-- privacy, a detail level and documentation, each of which has to be
-- answerable from the namespace alone, since the methods are queried with no
-- trace value. And that trace-dispatcher accepts the resulting tree, so that
-- every namespace is addressable.
--
-- What they do not check is the other direction: 'namespaceFor' is never
-- called, so a constructor whose namespace is missing from 'allNamespaces',
-- or a typo that appears in both places, still passes. Catching that needs
-- trace values, and these types have neither 'Arbitrary' nor 'Enum'
-- instances.
module Test.Consensus.Tracing.MetaTrace (tests) where

import Cardano.Logging
import Cardano.Protocol.Crypto (StandardCrypto)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Time.Clock (UTCTime)
import Ouroboros.Consensus.Block (Header)
import Ouroboros.Consensus.Block.SupportsSanityCheck (SanityCheckIssue)
import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent)
import Ouroboros.Consensus.Cardano.Block (CardanoBlock)
import Ouroboros.Consensus.Genesis.Governor (TraceGDDEvent)
import Ouroboros.Consensus.Mempool (TraceEventMempool)
import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server (TraceBlockFetchServerEvent)
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (TraceChainSyncClientEvent)
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping
import Ouroboros.Consensus.MiniProtocol.ChainSync.Server (TraceChainSyncServerEvent)
import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
  ( TraceLocalTxSubmissionServerEvent
  )
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert
  ( TracePerasCertDiffusionInbound
  , TracePerasCertDiffusionOutbound
  )
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasVote
  ( TracePerasVoteDiffusionInbound
  , TracePerasVoteDiffusionOutbound
  )
import Ouroboros.Consensus.Node.GSM (TraceGsmEvent)
import Ouroboros.Consensus.Node.Tracers
  ( TraceForgeEvent
  , TracePerasCertInclusionEvent
  , TracePerasVoteForgingEvent
  )
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentClientTrace)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import Ouroboros.Consensus.Tracing
  ( ClientMetrics
  , ConsensusStartupException
  , ReplayBlockStats
  )
import Ouroboros.Network.Block (Tip)
import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent)
import Test.Tasty
import Test.Tasty.HUnit

type Blk = CardanoBlock StandardCrypto

-- | Stand-in for the peer type of the per-peer tracers.
--
-- No 'MetaTrace' method looks at it -- namespaces, severities and documentation
-- are the same whatever a peer is -- so this picks the simplest inhabitant
-- rather than dragging in the node's address types.
type Peer = ()

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"MetaTrace"
    [ String -> [TestTree] -> TestTree
testGroup
        String
"consensus"
        [ forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceForgeEvent Blk) String
"TraceForgeEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceEventMempool Blk) String
"TraceEventMempool"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceChainSyncClientEvent Blk) String
"TraceChainSyncClientEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceChainSyncServerEvent Blk) String
"TraceChainSyncServerEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceBlockFetchServerEvent Blk) String
"TraceBlockFetchServerEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceLocalTxSubmissionServerEvent Blk)
            String
"TraceLocalTxSubmissionServerEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceGsmEvent (Tip Blk)) String
"TraceGsmEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceBlockchainTimeEvent UTCTime) String
"TraceBlockchainTimeEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @SanityCheckIssue String
"SanityCheckIssue"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @HotKey.KESInfo String
"KESInfo"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @ConsensusStartupException String
"ConsensusStartupException"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @ReplayBlockStats String
"ReplayBlockStats"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @ClientMetrics String
"ClientMetrics"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceGDDEvent Peer Blk) String
"TraceGDDEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(Jumping.TraceEventCsj Peer Blk) String
"Jumping.TraceEventCsj"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(Jumping.TraceEventDbf Peer) String
"Jumping.TraceEventDbf"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(BlockFetch.TraceFetchClientState (Header Blk))
            String
"BlockFetch.TraceFetchClientState"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TraceDecisionEvent Peer (Header Blk)) String
"TraceDecisionEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @KESAgentClientTrace String
"KESAgentClientTrace"
        ]
    , -- Only ChainDB. The LedgerDB, ImmutableDB, VolatileDB, PerasCertDB and
      -- PerasVoteDB tracers are not separate: ChainDbArgs derives each of them
      -- from the ChainDB tracer, and ChainDB.TraceEvent's allNamespaces maps all
      -- of their namespaces in under LedgerEvent, ImmDbEvent and so on. Listing
      -- them here as well checked every one of those namespaces twice, under two
      -- different names.
      String -> [TestTree] -> TestTree
testGroup
        String
"storage"
        [ forall a. MetaTrace a => String -> TestTree
metaTrace @(ChainDB.TraceEvent Blk) String
"ChainDB.TraceEvent"
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"peras"
        [ forall a. MetaTrace a => String -> TestTree
metaTrace @(TracePerasCertInclusionEvent Blk) String
"TracePerasCertInclusionEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TracePerasVoteForgingEvent Blk) String
"TracePerasVoteForgingEvent"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TracePerasCertDiffusionInbound Blk) String
"TracePerasCertDiffusionInbound"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TracePerasCertDiffusionOutbound Blk) String
"TracePerasCertDiffusionOutbound"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TracePerasVoteDiffusionInbound Blk) String
"TracePerasVoteDiffusionInbound"
        , forall a. MetaTrace a => String -> TestTree
metaTrace @(TracePerasVoteDiffusionOutbound Blk) String
"TracePerasVoteDiffusionOutbound"
        ]
    ]

-- | The checks that must hold for any 'MetaTrace' instance.
metaTrace :: forall a. MetaTrace a => String -> TestTree
metaTrace :: forall a. MetaTrace a => String -> TestTree
metaTrace String
name =
  String -> [TestTree] -> TestTree
testGroup
    String
name
    [ String -> Assertion -> TestTree
testCase String
"allNamespaces is non-empty" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
"no namespaces at all" (Bool -> Bool
not ([Namespace a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Namespace a]
nss))
    , String -> Assertion -> TestTree
testCase String
"no namespace is empty" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [Namespace a] -> Assertion
assertNoOffenders
          String
"namespace with no components"
          [Namespace a
ns | Namespace a
ns <- [Namespace a]
nss, [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsGetComplete Namespace a
ns)]
    , String -> Assertion -> TestTree
testCase String
"namespaces are unique" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [Namespace a] -> Assertion
assertNoOffenders String
"namespace listed more than once" [Namespace a]
duplicates
    , String -> Assertion -> TestTree
testCase String
"every namespace has a severity" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [Namespace a] -> Assertion
assertNoOffenders String
"no severityFor" [Namespace a
ns | Namespace a
ns <- [Namespace a]
nss, Maybe SeverityS
Nothing <- [Namespace a -> Maybe a -> Maybe SeverityS
forall a. MetaTrace a => Namespace a -> Maybe a -> Maybe SeverityS
severityFor Namespace a
ns Maybe a
forall a. Maybe a
Nothing]]
    , String -> Assertion -> TestTree
testCase String
"every namespace has a privacy" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [Namespace a] -> Assertion
assertNoOffenders String
"no privacyFor" [Namespace a
ns | Namespace a
ns <- [Namespace a]
nss, Maybe Privacy
Nothing <- [Namespace a -> Maybe a -> Maybe Privacy
forall a. MetaTrace a => Namespace a -> Maybe a -> Maybe Privacy
privacyFor Namespace a
ns Maybe a
forall a. Maybe a
Nothing]]
    , String -> Assertion -> TestTree
testCase String
"every namespace has a detail level" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [Namespace a] -> Assertion
assertNoOffenders String
"no detailsFor" [Namespace a
ns | Namespace a
ns <- [Namespace a]
nss, Maybe DetailLevel
Nothing <- [Namespace a -> Maybe a -> Maybe DetailLevel
forall a.
MetaTrace a =>
Namespace a -> Maybe a -> Maybe DetailLevel
detailsFor Namespace a
ns Maybe a
forall a. Maybe a
Nothing]]
    , -- A ratchet rather than a clean sheet: the namespaces in
      -- 'knownUndocumented' arrived undocumented and are recorded so that new
      -- ones cannot creep in. Write the documentation and delete the entry; the
      -- test below makes sure the list does not go stale.
      String -> Assertion -> TestTree
testCase String
"every namespace is documented" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [Namespace a] -> Assertion
assertNoOffenders
          String
"no documentFor, or blank"
          [Namespace a
ns | Namespace a
ns <- [Namespace a]
nss, Bool -> Bool
not (Namespace a -> Bool
forall {a}. MetaTrace a => Namespace a -> Bool
documented Namespace a
ns), Bool -> Bool
not (Namespace a -> Bool
forall {a}. Namespace a -> Bool
known Namespace a
ns)]
    , String -> Assertion -> TestTree
testCase String
"the undocumented-namespace list has no stale entries" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [Namespace a] -> Assertion
assertNoOffenders
          String
"documented now, so drop it from knownUndocumented"
          [Namespace a
ns | Namespace a
ns <- [Namespace a]
nss, Namespace a -> Bool
forall {a}. MetaTrace a => Namespace a -> Bool
documented Namespace a
ns, Namespace a -> Bool
forall {a}. Namespace a -> Bool
known Namespace a
ns]
    , -- The same check cardano-node runs over the assembled node configuration,
      -- here over one type's namespaces in isolation: it rejects a namespace that
      -- stops in the middle of another, which would make it unaddressable.
      String -> Assertion -> TestTree
testCase String
"trace-dispatcher accepts the namespace tree" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        case TraceConfig -> [([Text], [Text])] -> [Text]
checkTraceConfiguration' TraceConfig
emptyTraceConfig ((Namespace a -> ([Text], [Text]))
-> [Namespace a] -> [([Text], [Text])]
forall a b. (a -> b) -> [a] -> [b]
map Namespace a -> ([Text], [Text])
forall a. Namespace a -> ([Text], [Text])
nsGetTuple [Namespace a]
nss) of
          [] -> Peer -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          [Text]
warnings -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (Text -> String
Text.unpack (Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
warnings))
    ]
 where
  nss :: [Namespace a]
  nss :: [Namespace a]
nss = [Namespace a]
forall a. MetaTrace a => [Namespace a]
allNamespaces

  documented :: Namespace a -> Bool
documented Namespace a
ns = case Namespace a -> Maybe Text
forall a. MetaTrace a => Namespace a -> Maybe Text
documentFor Namespace a
ns of
    Maybe Text
Nothing -> Bool
False
    Just Text
doc -> Bool -> Bool
not (Text -> Bool
Text.null (Text -> Text
Text.strip Text
doc))

  known :: Namespace a -> Bool
known Namespace a
ns = (String
name, Namespace a -> Text
forall a. Namespace a -> Text
nsToText Namespace a
ns) (String, Text) -> Set (String, Text) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (String, Text)
knownUndocumented

  duplicates :: [Namespace a]
duplicates =
    [ Namespace a
ns
    | Namespace a
ns <- [Namespace a]
nss
    , let complete :: [Text]
complete = Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsGetComplete Namespace a
ns
    , [[Text]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([Text] -> Bool) -> [[Text]] -> [[Text]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
complete) ((Namespace a -> [Text]) -> [Namespace a] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map Namespace a -> [Text]
forall a. Namespace a -> [Text]
nsGetComplete [Namespace a]
nss)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
    ]

  assertNoOffenders :: String -> [Namespace a] -> Assertion
  assertNoOffenders :: String -> [Namespace a] -> Assertion
assertNoOffenders String
what [Namespace a]
offenders =
    HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool
      (String
what String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show (Set String -> [String]
forall a. Set a -> [a]
Set.toList ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ((Namespace a -> String) -> [Namespace a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Namespace a -> String
render [Namespace a]
offenders))))
      ([Namespace a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Namespace a]
offenders)

  render :: Namespace a -> String
  render :: Namespace a -> String
render = Text -> String
Text.unpack (Text -> String) -> (Namespace a -> Text) -> Namespace a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace a -> Text
forall a. Namespace a -> Text
nsToText

-- | Namespaces that have no documentation yet, keyed by the traced type.
--
-- All of these predate the move of the tracing instances into Consensus, and
-- live in ChainDB, ImmutableDB, LedgerDB and the forge tracer. They are listed
-- so that the check above can still reject a newly added namespace with no
-- documentation. Shrink this list, never grow it.
knownUndocumented :: Set.Set (String, Text.Text)
knownUndocumented :: Set (String, Text)
knownUndocumented =
  [(String, Text)] -> Set (String, Text)
forall a. Ord a => [a] -> Set a
Set.fromList
    [ (String
"BlockFetch.TraceFetchClientState", Text
"CompletedBlockFetch")
    , (String
"ChainDB.TraceEvent", Text
"AddBlockEvent.AddBlockValidation.UpdateLedgerDb")
    , (String
"ChainDB.TraceEvent", Text
"AddBlockEvent.AddedReprocessLoEBlocksToQueue")
    , (String
"ChainDB.TraceEvent", Text
"AddBlockEvent.ChainSelectionLoEDebug")
    , (String
"ChainDB.TraceEvent", Text
"AddBlockEvent.PoppedBlockFromQueue")
    , (String
"ChainDB.TraceEvent", Text
"AddBlockEvent.PoppedReprocessLoEBlocksFromQueue")
    , (String
"ChainDB.TraceEvent", Text
"AddBlockEvent.PoppingFromQueue")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.CacheEvent.PastChunkExpired")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.InvalidChunkFile")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.InvalidPrimaryIndex")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.InvalidSecondaryIndex")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.MissingChunkFile")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.MissingPrimaryIndex")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.MissingSecondaryIndex")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.RewritePrimaryIndex")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.RewriteSecondaryIndex")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.StartedValidatingChunk")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.ChunkValidation.ValidatedChunk")
    , (String
"ChainDB.TraceEvent", Text
"ImmDbEvent.DBAlreadyClosed")
    , (String
"ChainDB.TraceEvent", Text
"InitChainSelEvent.Validation.UpdateLedgerDb")
    , (String
"ChainDB.TraceEvent", Text
"IteratorEvent.UnknownRangeRequested.ForkTooOld")
    , (String
"ChainDB.TraceEvent", Text
"IteratorEvent.UnknownRangeRequested.MissingBlock")
    , (String
"KESAgentClientTrace", Text
"KESAgentClientException")
    , (String
"KESAgentClientTrace", Text
"ServiceClientAbnormalTermination")
    , (String
"KESAgentClientTrace", Text
"ServiceClientAttemptReconnect")
    , (String
"KESAgentClientTrace", Text
"ServiceClientConnected")
    , (String
"KESAgentClientTrace", Text
"ServiceClientDeclinedKey")
    , (String
"KESAgentClientTrace", Text
"ServiceClientDriverTrace")
    , (String
"KESAgentClientTrace", Text
"ServiceClientDroppedKey")
    , (String
"KESAgentClientTrace", Text
"ServiceClientOpCertNumberCheck")
    , (String
"KESAgentClientTrace", Text
"ServiceClientReceivedKey")
    , (String
"KESAgentClientTrace", Text
"ServiceClientSocketClosed")
    , (String
"KESAgentClientTrace", Text
"ServiceClientStopped")
    , (String
"KESAgentClientTrace", Text
"ServiceClientVersionHandshakeFailed")
    , (String
"KESAgentClientTrace", Text
"ServiceClientVersionHandshakeTrace")
    , (String
"TraceForgeEvent", Text
"ForgeTickedLedgerState")
    , (String
"TraceForgeEvent", Text
"ForgingMempoolSnapshot")
    ]