{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Tracing of the KES key state of a block forging credential.
--
-- 'HasKESInfo' and 'GetKESInfo' project the per-block-type
-- 'ForgeStateUpdateError'\/'ForgeStateInfo' onto the block-type-agnostic
-- 'HotKey.KESInfo', which is what actually gets traced. They live next to the
-- 'LogFormatting' instances that consume them so that a consumer of this
-- sublibrary gets both from a single import.
module Ouroboros.Consensus.Tracing.KESInfo
  ( HasKESInfo (..)
  , GetKESInfo (..)
  , traceAsKESInfo
  ) where

import Cardano.Logging
import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod))
import Control.Monad.IO.Class (MonadIO)
import Data.Aeson (ToJSON (..), Value (..), (.=))
import Data.SOP
import qualified Data.Text as Text
import Ouroboros.Consensus.Block.Forging
import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
import Ouroboros.Consensus.HardFork.Combinator
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
  ( OneEraForgeStateInfo (..)
  , OneEraForgeStateUpdateError (..)
  )
import Ouroboros.Consensus.Node.Tracers (TraceLabelCreds (..))
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock)
-- Brings the orphan @ForgeStateInfo@/@ForgeStateUpdateError@ type-family
-- instances for @ShelleyBlock@ into scope, so the KES instances below can
-- reduce them to @HotKey.KESInfo@/@HotKey.KESEvolutionError@.
import Ouroboros.Consensus.Shelley.Node ()
import Ouroboros.Consensus.TypeFamilyWrappers

--

-- * HasKESInfo

--
class HasKESInfo blk where
  getKESInfo :: Proxy blk -> ForgeStateUpdateError blk -> Maybe HotKey.KESInfo
  getKESInfo Proxy blk
_ ForgeStateUpdateError blk
_ = Maybe KESInfo
forall a. Maybe a
Nothing

instance HasKESInfo (ShelleyBlock protocol era) where
  getKESInfo :: Proxy (ShelleyBlock protocol era)
-> ForgeStateUpdateError (ShelleyBlock protocol era)
-> Maybe KESInfo
getKESInfo Proxy (ShelleyBlock protocol era)
_ (HotKey.KESCouldNotEvolve KESInfo
ki KESPeriod
_) = KESInfo -> Maybe KESInfo
forall a. a -> Maybe a
Just KESInfo
ki
  getKESInfo Proxy (ShelleyBlock protocol era)
_ (HotKey.KESKeyAlreadyPoisoned KESInfo
ki KESPeriod
_) = KESInfo -> Maybe KESInfo
forall a. a -> Maybe a
Just KESInfo
ki

instance HasKESInfo ByronBlock

instance All HasKESInfo xs => HasKESInfo (HardForkBlock xs) where
  getKESInfo :: Proxy (HardForkBlock xs)
-> ForgeStateUpdateError (HardForkBlock xs) -> Maybe KESInfo
getKESInfo Proxy (HardForkBlock xs)
_ =
    NS (K (Maybe KESInfo)) xs -> Maybe KESInfo
NS (K (Maybe KESInfo)) xs -> CollapseTo NS (Maybe KESInfo)
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
      (NS (K (Maybe KESInfo)) xs -> Maybe KESInfo)
-> (OneEraForgeStateUpdateError xs -> NS (K (Maybe KESInfo)) xs)
-> OneEraForgeStateUpdateError xs
-> Maybe KESInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy HasKESInfo
-> (forall a.
    HasKESInfo a =>
    WrapForgeStateUpdateError a -> K (Maybe KESInfo) a)
-> NS WrapForgeStateUpdateError xs
-> NS (K (Maybe KESInfo)) 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 (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @HasKESInfo) WrapForgeStateUpdateError a -> K (Maybe KESInfo) a
forall a.
HasKESInfo a =>
WrapForgeStateUpdateError a -> K (Maybe KESInfo) a
getOne
      (NS WrapForgeStateUpdateError xs -> NS (K (Maybe KESInfo)) xs)
-> (OneEraForgeStateUpdateError xs
    -> NS WrapForgeStateUpdateError xs)
-> OneEraForgeStateUpdateError xs
-> NS (K (Maybe KESInfo)) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraForgeStateUpdateError xs -> NS WrapForgeStateUpdateError xs
forall (xs :: [*]).
OneEraForgeStateUpdateError xs -> NS WrapForgeStateUpdateError xs
getOneEraForgeStateUpdateError
   where
    getOne ::
      forall blk.
      HasKESInfo blk =>
      WrapForgeStateUpdateError blk ->
      K (Maybe HotKey.KESInfo) blk
    getOne :: forall a.
HasKESInfo a =>
WrapForgeStateUpdateError a -> K (Maybe KESInfo) a
getOne = Maybe KESInfo -> K (Maybe KESInfo) blk
forall k a (b :: k). a -> K a b
K (Maybe KESInfo -> K (Maybe KESInfo) blk)
-> (WrapForgeStateUpdateError blk -> Maybe KESInfo)
-> WrapForgeStateUpdateError blk
-> K (Maybe KESInfo) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy blk -> ForgeStateUpdateError blk -> Maybe KESInfo
forall blk.
HasKESInfo blk =>
Proxy blk -> ForgeStateUpdateError blk -> Maybe KESInfo
getKESInfo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) (ForgeStateUpdateError blk -> Maybe KESInfo)
-> (WrapForgeStateUpdateError blk -> ForgeStateUpdateError blk)
-> WrapForgeStateUpdateError blk
-> Maybe KESInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapForgeStateUpdateError blk -> ForgeStateUpdateError blk
forall blk.
WrapForgeStateUpdateError blk -> ForgeStateUpdateError blk
unwrapForgeStateUpdateError

--

-- * GetKESInfo

--
class GetKESInfo blk where
  getKESInfoFromStateInfo :: Proxy blk -> ForgeStateInfo blk -> Maybe HotKey.KESInfo
  getKESInfoFromStateInfo Proxy blk
_ ForgeStateInfo blk
_ = Maybe KESInfo
forall a. Maybe a
Nothing

instance GetKESInfo (ShelleyBlock protocol era) where
  getKESInfoFromStateInfo :: Proxy (ShelleyBlock protocol era)
-> ForgeStateInfo (ShelleyBlock protocol era) -> Maybe KESInfo
getKESInfoFromStateInfo Proxy (ShelleyBlock protocol era)
_ = ForgeStateInfo (ShelleyBlock protocol era) -> Maybe KESInfo
KESInfo -> Maybe KESInfo
forall a. a -> Maybe a
Just

instance GetKESInfo ByronBlock

instance All GetKESInfo xs => GetKESInfo (HardForkBlock xs) where
  getKESInfoFromStateInfo :: Proxy (HardForkBlock xs)
-> ForgeStateInfo (HardForkBlock xs) -> Maybe KESInfo
getKESInfoFromStateInfo Proxy (HardForkBlock xs)
_ ForgeStateInfo (HardForkBlock xs)
forgeStateInfo =
    case ForgeStateInfo (HardForkBlock xs)
forgeStateInfo of
      CurrentEraLacksBlockForging EraIndex (x : y : xs1)
_ -> Maybe KESInfo
forall a. Maybe a
Nothing
      CurrentEraForgeStateUpdated OneEraForgeStateInfo xs
currentEraForgeStateInfo ->
        NS (K (Maybe KESInfo)) xs -> Maybe KESInfo
NS (K (Maybe KESInfo)) xs -> CollapseTo NS (Maybe KESInfo)
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
          (NS (K (Maybe KESInfo)) xs -> Maybe KESInfo)
-> (OneEraForgeStateInfo xs -> NS (K (Maybe KESInfo)) xs)
-> OneEraForgeStateInfo xs
-> Maybe KESInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy GetKESInfo
-> (forall a.
    GetKESInfo a =>
    WrapForgeStateInfo a -> K (Maybe KESInfo) a)
-> NS WrapForgeStateInfo xs
-> NS (K (Maybe KESInfo)) 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 (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @GetKESInfo) WrapForgeStateInfo a -> K (Maybe KESInfo) a
forall a.
GetKESInfo a =>
WrapForgeStateInfo a -> K (Maybe KESInfo) a
getOne
          (NS WrapForgeStateInfo xs -> NS (K (Maybe KESInfo)) xs)
-> (OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs)
-> OneEraForgeStateInfo xs
-> NS (K (Maybe KESInfo)) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
forall (xs :: [*]).
OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs
getOneEraForgeStateInfo
          (OneEraForgeStateInfo xs -> Maybe KESInfo)
-> OneEraForgeStateInfo xs -> Maybe KESInfo
forall a b. (a -> b) -> a -> b
$ OneEraForgeStateInfo xs
currentEraForgeStateInfo
   where
    getOne ::
      forall blk.
      GetKESInfo blk =>
      WrapForgeStateInfo blk ->
      K (Maybe HotKey.KESInfo) blk
    getOne :: forall a.
GetKESInfo a =>
WrapForgeStateInfo a -> K (Maybe KESInfo) a
getOne = Maybe KESInfo -> K (Maybe KESInfo) blk
forall k a (b :: k). a -> K a b
K (Maybe KESInfo -> K (Maybe KESInfo) blk)
-> (WrapForgeStateInfo blk -> Maybe KESInfo)
-> WrapForgeStateInfo blk
-> K (Maybe KESInfo) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy blk -> ForgeStateInfo blk -> Maybe KESInfo
forall blk.
GetKESInfo blk =>
Proxy blk -> ForgeStateInfo blk -> Maybe KESInfo
getKESInfoFromStateInfo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) (ForgeStateInfo blk -> Maybe KESInfo)
-> (WrapForgeStateInfo blk -> ForgeStateInfo blk)
-> WrapForgeStateInfo blk
-> Maybe KESInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapForgeStateInfo blk -> ForgeStateInfo blk
forall blk. WrapForgeStateInfo blk -> ForgeStateInfo blk
unwrapForgeStateInfo

--

-- * Tracer

--

traceAsKESInfo ::
  forall m blk.
  (GetKESInfo blk, MonadIO m) =>
  Proxy blk ->
  Trace m (TraceLabelCreds HotKey.KESInfo) ->
  Trace m (TraceLabelCreds (ForgeStateInfo blk))
traceAsKESInfo :: forall (m :: * -> *) blk.
(GetKESInfo blk, MonadIO m) =>
Proxy blk
-> Trace m (TraceLabelCreds KESInfo)
-> Trace m (TraceLabelCreds (ForgeStateInfo blk))
traceAsKESInfo Proxy blk
pr Trace m (TraceLabelCreds KESInfo)
tr = Proxy blk
-> Trace m (Maybe (TraceLabelCreds KESInfo))
-> Trace m (TraceLabelCreds (ForgeStateInfo blk))
forall (m :: * -> *) blk.
(GetKESInfo blk, MonadIO m) =>
Proxy blk
-> Trace m (Maybe (TraceLabelCreds KESInfo))
-> Trace m (TraceLabelCreds (ForgeStateInfo blk))
traceAsMaybeKESInfo Proxy blk
pr (Trace m (TraceLabelCreds KESInfo)
-> Trace m (Maybe (TraceLabelCreds KESInfo))
forall (m :: * -> *) a. Monad m => Trace m a -> Trace m (Maybe a)
filterTraceMaybe Trace m (TraceLabelCreds KESInfo)
tr)

traceAsMaybeKESInfo ::
  forall m blk.
  (GetKESInfo blk, MonadIO m) =>
  Proxy blk ->
  Trace m (Maybe (TraceLabelCreds HotKey.KESInfo)) ->
  Trace m (TraceLabelCreds (ForgeStateInfo blk))
traceAsMaybeKESInfo :: forall (m :: * -> *) blk.
(GetKESInfo blk, MonadIO m) =>
Proxy blk
-> Trace m (Maybe (TraceLabelCreds KESInfo))
-> Trace m (TraceLabelCreds (ForgeStateInfo blk))
traceAsMaybeKESInfo Proxy blk
pr (Trace Tracer
  m
  (LoggingContext,
   Either TraceControl (Maybe (TraceLabelCreds KESInfo)))
tr) =
  Tracer
  m
  (LoggingContext,
   Either TraceControl (TraceLabelCreds (ForgeStateInfo blk)))
-> Trace m (TraceLabelCreds (ForgeStateInfo blk))
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer
   m
   (LoggingContext,
    Either TraceControl (TraceLabelCreds (ForgeStateInfo blk)))
 -> Trace m (TraceLabelCreds (ForgeStateInfo blk)))
-> Tracer
     m
     (LoggingContext,
      Either TraceControl (TraceLabelCreds (ForgeStateInfo blk)))
-> Trace m (TraceLabelCreds (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext,
  Either TraceControl (TraceLabelCreds (ForgeStateInfo blk)))
 -> (LoggingContext,
     Either TraceControl (Maybe (TraceLabelCreds KESInfo))))
-> Tracer
     m
     (LoggingContext,
      Either TraceControl (Maybe (TraceLabelCreds KESInfo)))
-> Tracer
     m
     (LoggingContext,
      Either TraceControl (TraceLabelCreds (ForgeStateInfo blk)))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
      ( \case
          (LoggingContext
lc, Right (TraceLabelCreds Text
c ForgeStateInfo blk
e)) ->
            case Proxy blk -> ForgeStateInfo blk -> Maybe KESInfo
forall blk.
GetKESInfo blk =>
Proxy blk -> ForgeStateInfo blk -> Maybe KESInfo
getKESInfoFromStateInfo Proxy blk
pr ForgeStateInfo blk
e of
              Just KESInfo
kesi -> (LoggingContext
lc, Maybe (TraceLabelCreds KESInfo)
-> Either TraceControl (Maybe (TraceLabelCreds KESInfo))
forall a b. b -> Either a b
Right (TraceLabelCreds KESInfo -> Maybe (TraceLabelCreds KESInfo)
forall a. a -> Maybe a
Just (Text -> KESInfo -> TraceLabelCreds KESInfo
forall a. Text -> a -> TraceLabelCreds a
TraceLabelCreds Text
c KESInfo
kesi)))
              Maybe KESInfo
Nothing -> (LoggingContext
lc, Maybe (TraceLabelCreds KESInfo)
-> Either TraceControl (Maybe (TraceLabelCreds KESInfo))
forall a b. b -> Either a b
Right Maybe (TraceLabelCreds KESInfo)
forall a. Maybe a
Nothing)
          (LoggingContext
lc, Left TraceControl
ctrl) -> (LoggingContext
lc, TraceControl
-> Either TraceControl (Maybe (TraceLabelCreds KESInfo))
forall a b. a -> Either a b
Left TraceControl
ctrl)
      )
      Tracer
  m
  (LoggingContext,
   Either TraceControl (Maybe (TraceLabelCreds KESInfo)))
tr

-- --------------------------------------------------------------------------------
-- -- KESInfo Tracer
-- --------------------------------------------------------------------------------

deriving newtype instance ToJSON KESPeriod

instance LogFormatting HotKey.KESInfo where
  forMachine :: DetailLevel -> KESInfo -> Object
forMachine DetailLevel
_dtal KESInfo
forgeStateInfo =
    let currKesPeriod' :: Word
currKesPeriod' = Word
currKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
startKesPeriod
        maxKesEvos :: Word
maxKesEvos = Word
endKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
startKesPeriod
        expiryKesPeriod :: Word
expiryKesPeriod = Word
startKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
maxKesEvos
        kesPeriodsUntilExpiry :: Word
kesPeriodsUntilExpiry = Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
0 (Word
expiryKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
currKesPeriod')
     in if Word
kesPeriodsUntilExpiry Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
7
          then
            [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
              [ Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"KESInfo"
              , Key
"startPeriod" Key -> Word -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
startKesPeriod
              , Key
"endPeriod" Key -> Word -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
currKesPeriod'
              , Key
"evolution" Key -> Word -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
endKesPeriod
              ]
          else
            [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
              [ Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ExpiryLogMessage"
              , Key
"keyExpiresIn" Key -> Word -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
kesPeriodsUntilExpiry
              , Key
"startPeriod" Key -> Word -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
startKesPeriod
              , Key
"endPeriod" Key -> Word -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
currKesPeriod'
              , Key
"evolution" Key -> Word -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word
endKesPeriod
              ]
   where
    HotKey.KESInfo
      { kesStartPeriod :: KESInfo -> KESPeriod
HotKey.kesStartPeriod = KESPeriod Word
startKesPeriod
      , kesEvolution :: KESInfo -> Word
HotKey.kesEvolution = Word
currKesPeriod
      , kesEndPeriod :: KESInfo -> KESPeriod
HotKey.kesEndPeriod = KESPeriod Word
endKesPeriod
      } = KESInfo
forgeStateInfo

  forHuman :: KESInfo -> Text
forHuman KESInfo
forgeStateInfo =
    let currKesPeriod' :: Word
currKesPeriod' = Word
currKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
startKesPeriod
        maxKesEvos :: Word
maxKesEvos = Word
endKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
startKesPeriod
        expiryKesPeriod :: Word
expiryKesPeriod = Word
startKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
maxKesEvos
        kesPeriodsUntilExpiry :: Word
kesPeriodsUntilExpiry = Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
0 (Word
expiryKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
currKesPeriod')
     in if Word
kesPeriodsUntilExpiry Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
7
          then
            Text
"KES info startPeriod  "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show) Word
startKesPeriod
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" currPeriod "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show) Word
currKesPeriod'
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" endPeriod "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show) Word
endKesPeriod
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show) Word
kesPeriodsUntilExpiry
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" KES periods until expiry."
          else
            Text
"Operational key will expire in "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show) Word
kesPeriodsUntilExpiry
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" KES periods."
   where
    HotKey.KESInfo
      { kesStartPeriod :: KESInfo -> KESPeriod
HotKey.kesStartPeriod = KESPeriod Word
startKesPeriod
      , kesEvolution :: KESInfo -> Word
HotKey.kesEvolution = Word
currKesPeriod
      , kesEndPeriod :: KESInfo -> KESPeriod
HotKey.kesEndPeriod = KESPeriod Word
endKesPeriod
      } = KESInfo
forgeStateInfo

  asMetrics :: KESInfo -> [Metric]
asMetrics KESInfo
forgeStateInfo =
    let currKesPeriod' :: Word
currKesPeriod' = Word
currKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
startKesPeriod
        maxKesEvos :: Word
maxKesEvos = Word
endKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
startKesPeriod
        expiryKesPeriod :: Word
expiryKesPeriod = Word
startKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
maxKesEvos
        kesPeriodsUntilExpiry :: Word
kesPeriodsUntilExpiry = Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
0 (Word
expiryKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
currKesPeriod')
     in [ Text -> Integer -> Metric
IntM Text
"operationalCertificateStartKESPeriod" (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
startKesPeriod)
        , Text -> Integer -> Metric
IntM Text
"operationalCertificateExpiryKESPeriod" (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
expiryKesPeriod)
        , Text -> Integer -> Metric
IntM Text
"currentKESPeriod" (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
currKesPeriod')
        , Text -> Integer -> Metric
IntM Text
"remainingKESPeriods" (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
kesPeriodsUntilExpiry)
        ]
   where
    HotKey.KESInfo
      { kesStartPeriod :: KESInfo -> KESPeriod
HotKey.kesStartPeriod = KESPeriod Word
startKesPeriod
      , kesEvolution :: KESInfo -> Word
HotKey.kesEvolution = Word
currKesPeriod
      , kesEndPeriod :: KESInfo -> KESPeriod
HotKey.kesEndPeriod = KESPeriod Word
endKesPeriod
      } = KESInfo
forgeStateInfo

instance MetaTrace HotKey.KESInfo where
  namespaceFor :: KESInfo -> Namespace KESInfo
namespaceFor HotKey.KESInfo{} = [Text] -> [Text] -> Namespace KESInfo
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"StateInfo"]

  severityFor :: Namespace KESInfo -> Maybe KESInfo -> Maybe SeverityS
severityFor (Namespace [Text]
_ [Text]
_) (Just KESInfo
forgeStateInfo) =
    SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just (SeverityS -> Maybe SeverityS) -> SeverityS -> Maybe SeverityS
forall a b. (a -> b) -> a -> b
$
      let currKesPeriod' :: Word
currKesPeriod' = Word
currKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
startKesPeriod
          maxKesEvos :: Word
maxKesEvos = Word
endKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
startKesPeriod
          expiryKesPeriod :: Word
expiryKesPeriod = Word
startKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
maxKesEvos
          kesPeriodsUntilExpiry :: Word
kesPeriodsUntilExpiry = Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
0 (Word
expiryKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
currKesPeriod')
       in if Word
kesPeriodsUntilExpiry Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
7
            then SeverityS
Info
            else
              if Word
kesPeriodsUntilExpiry Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
1
                then SeverityS
Alert
                else SeverityS
Warning
   where
    HotKey.KESInfo
      { kesStartPeriod :: KESInfo -> KESPeriod
HotKey.kesStartPeriod = KESPeriod Word
startKesPeriod
      , kesEvolution :: KESInfo -> Word
HotKey.kesEvolution = Word
currKesPeriod
      , kesEndPeriod :: KESInfo -> KESPeriod
HotKey.kesEndPeriod = KESPeriod Word
endKesPeriod
      } = KESInfo
forgeStateInfo
  severityFor (Namespace [Text]
_ [Text
"StateInfo"]) Maybe KESInfo
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Info
  severityFor Namespace KESInfo
_ Maybe KESInfo
_ = Maybe SeverityS
forall a. Maybe a
Nothing

  documentFor :: Namespace KESInfo -> Maybe Text
documentFor (Namespace [Text]
_ [Text
"StateInfo"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just
      Text
"kesStartPeriod \
      \\nkesEndPeriod is kesStartPeriod + tpraosMaxKESEvo\
      \\nkesEvolution is the current evolution or /relative period/."
  documentFor Namespace KESInfo
_ = Maybe Text
forall a. Maybe a
Nothing

  metricsDocFor :: Namespace KESInfo -> [(Text, Text)]
metricsDocFor (Namespace [Text]
_ [Text
"StateInfo"]) =
    [ (Text
"operationalCertificateStartKESPeriod", Text
"")
    , (Text
"operationalCertificateExpiryKESPeriod", Text
"")
    , (Text
"currentKESPeriod", Text
"")
    , (Text
"remainingKESPeriods", Text
"")
    ]
  metricsDocFor Namespace KESInfo
_ = []

  allNamespaces :: [Namespace KESInfo]
allNamespaces = [[Text] -> [Text] -> Namespace KESInfo
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"StateInfo"]]

instance LogFormatting HotKey.KESEvolutionError where
  forMachine :: DetailLevel -> KESEvolutionError -> Object
forMachine DetailLevel
dtal (HotKey.KESCouldNotEvolve KESInfo
kesInfo KESPeriod
targetPeriod) =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"KESCouldNotEvolve"
      , Key
"kesInfo" Key -> Object -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> KESInfo -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal KESInfo
kesInfo
      , Key
"targetPeriod" Key -> KESPeriod -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KESPeriod
targetPeriod
      ]
  forMachine DetailLevel
dtal (HotKey.KESKeyAlreadyPoisoned KESInfo
kesInfo KESPeriod
targetPeriod) =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"KESKeyAlreadyPoisoned"
      , Key
"kesInfo" Key -> Object -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> KESInfo -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal KESInfo
kesInfo
      , Key
"targetPeriod" Key -> KESPeriod -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KESPeriod
targetPeriod
      ]