{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Tracing.Metrics
  ( KESMetricsData (..)
  , MaxKESEvolutions (..)
  , OperationalCertStartKESPeriod (..)
  , HasKESMetricsData (..)
  ) where

import           Cardano.Prelude hiding (All, (:.:))

import           Cardano.Crypto.KES.Class (Period)
import           Data.SOP.Strict (All, hcmap, K (..), hcollapse)
import           Ouroboros.Consensus.Block (ForgeStateInfo)
import           Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.TypeFamilyWrappers (WrapForgeStateInfo (..))
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (OneEraForgeStateInfo (..))
import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock)
import           Ouroboros.Consensus.Shelley.Node ()
import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey
import           Shelley.Spec.Ledger.OCert (KESPeriod (..))


-- | KES-related data to be traced as metrics.
data KESMetricsData
  = NoKESMetricsData
  -- ^ The current protocol does not support KES.
  | TPraosKESMetricsData
      !Period
      -- ^ The current KES period of the hot key, relative to the start KES
      -- period of the operational certificate.
      !MaxKESEvolutions
      -- ^ The configured max KES evolutions.
      !OperationalCertStartKESPeriod
      -- ^ The start KES period of the configured operational certificate.

-- | The maximum number of evolutions that a KES key can undergo before it is
-- considered expired.
newtype MaxKESEvolutions = MaxKESEvolutions Word64

-- | The start KES period of the configured operational certificate.
newtype OperationalCertStartKESPeriod = OperationalCertStartKESPeriod Period

class HasKESMetricsData blk where
  -- Because 'ForgeStateInfo' is a type family, we need a Proxy argument to
  -- disambiguate.
  getKESMetricsData :: Proxy blk -> ForgeStateInfo blk -> KESMetricsData

  -- Default to 'NoKESMetricsData'
  getKESMetricsData Proxy blk
_ ForgeStateInfo blk
_ = KESMetricsData
NoKESMetricsData

instance HasKESMetricsData (ShelleyBlock c) where
  getKESMetricsData :: Proxy (ShelleyBlock c)
-> ForgeStateInfo (ShelleyBlock c) -> KESMetricsData
getKESMetricsData Proxy (ShelleyBlock c)
_ ForgeStateInfo (ShelleyBlock c)
forgeStateInfo =
      Period
-> MaxKESEvolutions
-> OperationalCertStartKESPeriod
-> KESMetricsData
TPraosKESMetricsData Period
currKesPeriod MaxKESEvolutions
maxKesEvos OperationalCertStartKESPeriod
oCertStartKesPeriod
    where
      HotKey.KESInfo
        { kesStartPeriod :: KESInfo -> KESPeriod
kesStartPeriod = KESPeriod Period
startKesPeriod
        , kesEvolution :: KESInfo -> Period
kesEvolution = Period
currKesPeriod
        , kesEndPeriod :: KESInfo -> KESPeriod
kesEndPeriod = KESPeriod Period
endKesPeriod
        } = ForgeStateInfo (ShelleyBlock c)
KESInfo
forgeStateInfo

      maxKesEvos :: MaxKESEvolutions
maxKesEvos = Word64 -> MaxKESEvolutions
MaxKESEvolutions (Word64 -> MaxKESEvolutions) -> Word64 -> MaxKESEvolutions
forall a b. (a -> b) -> a -> b
$
          Period -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Period -> Word64) -> Period -> Word64
forall a b. (a -> b) -> a -> b
$ Period
endKesPeriod Period -> Period -> Period
forall a. Num a => a -> a -> a
- Period
startKesPeriod

      oCertStartKesPeriod :: OperationalCertStartKESPeriod
oCertStartKesPeriod = Period -> OperationalCertStartKESPeriod
OperationalCertStartKESPeriod Period
startKesPeriod

instance HasKESMetricsData ByronBlock where

instance All HasKESMetricsData xs => HasKESMetricsData (HardForkBlock xs) where
  getKESMetricsData :: Proxy (HardForkBlock xs)
-> ForgeStateInfo (HardForkBlock xs) -> KESMetricsData
getKESMetricsData Proxy (HardForkBlock xs)
_ ForgeStateInfo (HardForkBlock xs)
forgeStateInfo =
        NS (K KESMetricsData) xs -> KESMetricsData
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
      (NS (K KESMetricsData) xs -> KESMetricsData)
-> (OneEraForgeStateInfo xs -> NS (K KESMetricsData) xs)
-> OneEraForgeStateInfo xs
-> KESMetricsData
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Proxy HasKESMetricsData
-> (forall a.
    HasKESMetricsData a =>
    WrapForgeStateInfo a -> K KESMetricsData a)
-> NS WrapForgeStateInfo xs
-> NS (K KESMetricsData) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (Proxy HasKESMetricsData
forall k (t :: k). Proxy t
Proxy @HasKESMetricsData) forall a.
HasKESMetricsData a =>
WrapForgeStateInfo a -> K KESMetricsData a
getOne
      (NS WrapForgeStateInfo xs -> NS (K KESMetricsData) xs)
-> (OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs)
-> OneEraForgeStateInfo xs
-> NS (K KESMetricsData) xs
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
forall (xs :: [*]).
OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
getOneEraForgeStateInfo
      (OneEraForgeStateInfo xs -> KESMetricsData)
-> OneEraForgeStateInfo xs -> KESMetricsData
forall a b. (a -> b) -> a -> b
$ OneEraForgeStateInfo xs
ForgeStateInfo (HardForkBlock xs)
forgeStateInfo
    where
      getOne :: forall blk. HasKESMetricsData blk
             => WrapForgeStateInfo blk
             -> K KESMetricsData blk
      getOne :: WrapForgeStateInfo blk -> K KESMetricsData blk
getOne = KESMetricsData -> K KESMetricsData blk
forall k a (b :: k). a -> K a b
K (KESMetricsData -> K KESMetricsData blk)
-> (WrapForgeStateInfo blk -> KESMetricsData)
-> WrapForgeStateInfo blk
-> K KESMetricsData blk
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Proxy blk -> ForgeStateInfo blk -> KESMetricsData
forall blk.
HasKESMetricsData blk =>
Proxy blk -> ForgeStateInfo blk -> KESMetricsData
getKESMetricsData (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (ForgeStateInfo blk -> KESMetricsData)
-> (WrapForgeStateInfo blk -> ForgeStateInfo blk)
-> WrapForgeStateInfo blk
-> KESMetricsData
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WrapForgeStateInfo blk -> ForgeStateInfo blk
forall blk. WrapForgeStateInfo blk -> ForgeStateInfo blk
unwrapForgeStateInfo