{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PackageImports #-}

module Cardano.Node.Tracing.Tracers.StartLeadershipCheck
  ( TraceStartLeadershipCheckPlus (..)
  , ForgeTracerType
  , forgeTracerTransform
  ) where


import           Cardano.Logging
import           Cardano.Prelude
import qualified "trace-dispatcher" Control.Tracer as T
import           Data.IORef (readIORef)

import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (BlockNo (..), blockNo, unBlockNo)
import           Ouroboros.Network.NodeToClient (LocalConnectionId)
import           Ouroboros.Network.NodeToNode (RemoteConnectionId)

import           Ouroboros.Consensus.Block (SlotNo (..))
import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.Ledger.Abstract (IsLedger)
import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState)
import           Ouroboros.Consensus.Node (NodeKernel (..))
import           Ouroboros.Consensus.Node.Tracers
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB

import           Cardano.Node.Queries (LedgerQueries (..), NodeKernelData (..))
import           Cardano.Slotting.Slot (fromWithOrigin)

import           Cardano.Ledger.BaseTypes (StrictMaybe (..), fromSMaybe)


type ForgeTracerType blk = Either (TraceForgeEvent blk)
                                  TraceStartLeadershipCheckPlus

data TraceStartLeadershipCheckPlus =
  TraceStartLeadershipCheckPlus {
        TraceStartLeadershipCheckPlus -> SlotNo
tsSlotNo       :: SlotNo
      , TraceStartLeadershipCheckPlus -> Int
tsUtxoSize     :: Int
      , TraceStartLeadershipCheckPlus -> Int
tsDelegMapSize :: Int
      , TraceStartLeadershipCheckPlus -> Double
tsChainDensity :: Double
    }

forgeTracerTransform ::
  (  IsLedger (LedgerState blk)
  ,  LedgerQueries blk
  ,  AF.HasHeader (Header blk))
  => NodeKernelData blk
  -> Trace IO (ForgeTracerType blk)
  -> IO (Trace IO (ForgeTracerType blk))
forgeTracerTransform :: NodeKernelData blk
-> Trace IO (ForgeTracerType blk)
-> IO (Trace IO (ForgeTracerType blk))
forgeTracerTransform NodeKernelData blk
nodeKern (Trace Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
tr) = Trace IO (ForgeTracerType blk)
-> IO (Trace IO (ForgeTracerType blk))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO (ForgeTracerType blk)
 -> IO (Trace IO (ForgeTracerType blk)))
-> Trace IO (ForgeTracerType blk)
-> IO (Trace IO (ForgeTracerType blk))
forall a b. (a -> b) -> a -> b
$ Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> Trace IO (ForgeTracerType blk)
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer
   IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
 -> Trace IO (ForgeTracerType blk))
-> Tracer
     IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> Trace IO (ForgeTracerType blk)
forall a b. (a -> b) -> a -> b
$ TracerA
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk)) ()
-> Tracer
     IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.arrow (TracerA
   IO (LoggingContext, Either TraceControl (ForgeTracerType blk)) ()
 -> Tracer
      IO (LoggingContext, Either TraceControl (ForgeTracerType blk)))
-> TracerA
     IO (LoggingContext, Either TraceControl (ForgeTracerType blk)) ()
-> Tracer
     IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl (ForgeTracerType blk))
 -> IO ())
-> TracerA
     IO (LoggingContext, Either TraceControl (ForgeTracerType blk)) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit (((LoggingContext, Either TraceControl (ForgeTracerType blk))
  -> IO ())
 -> TracerA
      IO (LoggingContext, Either TraceControl (ForgeTracerType blk)) ())
-> ((LoggingContext, Either TraceControl (ForgeTracerType blk))
    -> IO ())
-> TracerA
     IO (LoggingContext, Either TraceControl (ForgeTracerType blk)) ()
forall a b. (a -> b) -> a -> b
$
    \case
      (LoggingContext
lc, Right (Left slc :: TraceForgeEvent blk
slc@(TraceStartLeadershipCheck SlotNo
slotNo))) -> do
        StrictMaybe (Int, Int, Rational)
query <- (NodeKernel IO RemoteConnectionId LocalConnectionId blk
 -> IO (Int, Int, Rational))
-> NodeKernelData blk -> IO (StrictMaybe (Int, Int, Rational))
forall blk a.
(NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
-> NodeKernelData blk -> IO (StrictMaybe a)
mapNodeKernelDataIO
                    (\NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk ->
                       (,,)
                         (Int -> Int -> Rational -> (Int, Int, Rational))
-> IO Int -> IO (Int -> Rational -> (Int, Int, Rational))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExtLedgerState blk -> Int)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int
forall blk a.
IsLedger (LedgerState blk) =>
(ExtLedgerState blk -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryLedger (LedgerState blk -> Int
forall blk. LedgerQueries blk => LedgerState blk -> Int
ledgerUtxoSize (LedgerState blk -> Int)
-> (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk
-> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState) NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk
                         IO (Int -> Rational -> (Int, Int, Rational))
-> IO Int -> IO (Rational -> (Int, Int, Rational))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ExtLedgerState blk -> Int)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int
forall blk a.
IsLedger (LedgerState blk) =>
(ExtLedgerState blk -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryLedger (LedgerState blk -> Int
forall blk. LedgerQueries blk => LedgerState blk -> Int
ledgerDelegMapSize (LedgerState blk -> Int)
-> (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk
-> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState) NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk
                         IO (Rational -> (Int, Int, Rational))
-> IO Rational -> IO (Int, Int, Rational)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (AnchoredFragment (Header blk) -> Rational)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO Rational
forall blk a.
(AnchoredFragment (Header blk) -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryChain AnchoredFragment (Header blk) -> Rational
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Rational
fragmentChainDensity NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk)
                    NodeKernelData blk
nodeKern
        IO () -> StrictMaybe (IO ()) -> IO ()
forall a. a -> StrictMaybe a -> a
fromSMaybe
           (Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
tr (LoggingContext
lc, ForgeTracerType blk -> Either TraceControl (ForgeTracerType blk)
forall a b. b -> Either a b
Right (TraceForgeEvent blk -> ForgeTracerType blk
forall a b. a -> Either a b
Left TraceForgeEvent blk
slc)))
           (StrictMaybe (Int, Int, Rational)
query StrictMaybe (Int, Int, Rational)
-> ((Int, Int, Rational) -> IO ()) -> StrictMaybe (IO ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
             \(Int
utxoSize, Int
delegMapSize, Rational
chainDensity) ->
                let msg :: TraceStartLeadershipCheckPlus
msg = SlotNo -> Int -> Int -> Double -> TraceStartLeadershipCheckPlus
TraceStartLeadershipCheckPlus
                            SlotNo
slotNo
                            Int
utxoSize
                            Int
delegMapSize
                            (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
chainDensity)
                in Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
tr (LoggingContext
lc, ForgeTracerType blk -> Either TraceControl (ForgeTracerType blk)
forall a b. b -> Either a b
Right (TraceStartLeadershipCheckPlus -> ForgeTracerType blk
forall a b. b -> Either a b
Right TraceStartLeadershipCheckPlus
msg)))
      (LoggingContext
lc, Right ForgeTracerType blk
a) ->
          Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
tr (LoggingContext
lc, ForgeTracerType blk -> Either TraceControl (ForgeTracerType blk)
forall a b. b -> Either a b
Right ForgeTracerType blk
a)
      (LoggingContext
lc, Left TraceControl
control) ->
          Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> (LoggingContext, Either TraceControl (ForgeTracerType blk))
-> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer
  IO (LoggingContext, Either TraceControl (ForgeTracerType blk))
tr (LoggingContext
lc, TraceControl -> Either TraceControl (ForgeTracerType blk)
forall a b. a -> Either a b
Left TraceControl
control)

nkQueryLedger ::
     IsLedger (LedgerState blk)
  => (ExtLedgerState blk -> a)
  -> NodeKernel IO RemoteConnectionId LocalConnectionId blk
  -> IO a
nkQueryLedger :: (ExtLedgerState blk -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryLedger ExtLedgerState blk -> a
f NodeKernel{ChainDB IO blk
$sel:getChainDB:NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> ChainDB m blk
getChainDB :: ChainDB IO blk
getChainDB} =
  ExtLedgerState blk -> a
f (ExtLedgerState blk -> a) -> IO (ExtLedgerState blk) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (ExtLedgerState blk) -> IO (ExtLedgerState blk)
forall a. STM a -> IO a
atomically (ChainDB IO blk -> STM IO (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB IO blk
getChainDB)

fragmentChainDensity ::
  AF.HasHeader (Header blk)
  => AF.AnchoredFragment (Header blk) -> Rational
fragmentChainDensity :: AnchoredFragment (Header blk) -> Rational
fragmentChainDensity AnchoredFragment (Header blk)
frag = Word64 -> Word64 -> Rational
calcDensity Word64
blockD Word64
slotD
  where
    calcDensity :: Word64 -> Word64 -> Rational
    calcDensity :: Word64 -> Word64 -> Rational
calcDensity Word64
bl Word64
sl
      | Word64
sl Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 = Word64 -> Rational
forall a. Real a => a -> Rational
toRational Word64
bl Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Word64 -> Rational
forall a. Real a => a -> Rational
toRational Word64
sl
      | Bool
otherwise = Rational
0
    slotN :: Word64
slotN  = SlotNo -> Word64
unSlotNo (SlotNo -> Word64) -> SlotNo -> Word64
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (AnchoredFragment (Header blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment (Header blk)
frag)
    -- Slot of the tip - slot @k@ blocks back. Use 0 as the slot for genesis
    -- includes EBBs
    slotD :: Word64
slotD   = Word64
slotN
            Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo (SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (AnchoredFragment (Header blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.lastSlot AnchoredFragment (Header blk)
frag))
    -- Block numbers start at 1. We ignore the genesis EBB, which has block number 0.
    blockD :: Word64
blockD = Word64
blockN Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
firstBlock
    blockN :: Word64
blockN = BlockNo -> Word64
unBlockNo (BlockNo -> Word64) -> BlockNo -> Word64
forall a b. (a -> b) -> a -> b
$ BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (Word64 -> BlockNo
BlockNo Word64
1) (AnchoredFragment (Header blk) -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment (Header blk)
frag)
    firstBlock :: Word64
firstBlock = case BlockNo -> Word64
unBlockNo (BlockNo -> Word64)
-> (Header blk -> BlockNo) -> Header blk -> Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo (Header blk -> Word64)
-> Either (Anchor (Header blk)) (Header blk)
-> Either (Anchor (Header blk)) Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredFragment (Header blk)
-> Either (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.last AnchoredFragment (Header blk)
frag of
      -- Empty fragment, no blocks. We have that @blocks = 1 - 1 = 0@
      Left Anchor (Header blk)
_  -> Word64
1
      -- The oldest block is the genesis EBB with block number 0,
      -- don't let it contribute to the number of blocks
      Right Word64
0 -> Word64
1
      Right Word64
b -> Word64
b

nkQueryChain ::
     (AF.AnchoredFragment (Header blk) -> a)
  -> NodeKernel IO RemoteConnectionId LocalConnectionId blk
  -> IO a
nkQueryChain :: (AnchoredFragment (Header blk) -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryChain AnchoredFragment (Header blk) -> a
f NodeKernel{ChainDB IO blk
getChainDB :: ChainDB IO blk
$sel:getChainDB:NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> ChainDB m blk
getChainDB} =
  AnchoredFragment (Header blk) -> a
f (AnchoredFragment (Header blk) -> a)
-> IO (AnchoredFragment (Header blk)) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (AnchoredFragment (Header blk))
-> IO (AnchoredFragment (Header blk))
forall a. STM a -> IO a
atomically (ChainDB IO blk -> STM IO (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB IO blk
getChainDB)


mapNodeKernelDataIO ::
  (NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
  -> NodeKernelData blk
  -> IO (StrictMaybe a)
mapNodeKernelDataIO :: (NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
-> NodeKernelData blk -> IO (StrictMaybe a)
mapNodeKernelDataIO NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
f (NodeKernelData IORef
  (StrictMaybe
     (NodeKernel IO RemoteConnectionId LocalConnectionId blk))
ref) =
  IORef
  (StrictMaybe
     (NodeKernel IO RemoteConnectionId LocalConnectionId blk))
-> IO
     (StrictMaybe
        (NodeKernel IO RemoteConnectionId LocalConnectionId blk))
forall a. IORef a -> IO a
readIORef IORef
  (StrictMaybe
     (NodeKernel IO RemoteConnectionId LocalConnectionId blk))
ref IO
  (StrictMaybe
     (NodeKernel IO RemoteConnectionId LocalConnectionId blk))
-> (StrictMaybe
      (NodeKernel IO RemoteConnectionId LocalConnectionId blk)
    -> IO (StrictMaybe a))
-> IO (StrictMaybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
-> StrictMaybe
     (NodeKernel IO RemoteConnectionId LocalConnectionId blk)
-> IO (StrictMaybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
f