{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.HardFork.Simple (TriggerHardFork (..)) where

import           Cardano.Binary
import           Cardano.Slotting.Slot (EpochNo)
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.Node.Serialisation

-- | The trigger condition that will cause the hard fork transition.
--
-- This type is only intended for use as part of a
-- 'Ouroboros.Consensus.Ledger.Basics.LedgerCfg', which means it is "static":
-- it cannot change during an execution of the node process.
data TriggerHardFork =
    -- | Trigger the transition when the on-chain protocol major version (from
    -- the ledger state) reaches this number.
    --
    -- Note: The HFC logic does not require the trigger version for one era to
    -- be the successor of the trigger version for the previous era.
    TriggerHardForkAtVersion !Word16
    -- | For testing only, trigger the transition at a specific hard-coded
    -- epoch, irrespective of the ledger state.
  | TriggerHardForkAtEpoch !EpochNo
    -- | Ledger states in this era cannot determine when the hard fork
    -- transition will happen.
    --
    -- It's crucial to note that this option does /not/ imply that "the era
    -- will never end". Instead, the era cannot end within this node process
    -- before it restarts with different software and/or configuration for this
    -- era.
  | TriggerHardForkNotDuringThisExecution
  deriving (Int -> TriggerHardFork -> ShowS
[TriggerHardFork] -> ShowS
TriggerHardFork -> String
(Int -> TriggerHardFork -> ShowS)
-> (TriggerHardFork -> String)
-> ([TriggerHardFork] -> ShowS)
-> Show TriggerHardFork
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TriggerHardFork -> ShowS
showsPrec :: Int -> TriggerHardFork -> ShowS
$cshow :: TriggerHardFork -> String
show :: TriggerHardFork -> String
$cshowList :: [TriggerHardFork] -> ShowS
showList :: [TriggerHardFork] -> ShowS
Show, (forall x. TriggerHardFork -> Rep TriggerHardFork x)
-> (forall x. Rep TriggerHardFork x -> TriggerHardFork)
-> Generic TriggerHardFork
forall x. Rep TriggerHardFork x -> TriggerHardFork
forall x. TriggerHardFork -> Rep TriggerHardFork x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TriggerHardFork -> Rep TriggerHardFork x
from :: forall x. TriggerHardFork -> Rep TriggerHardFork x
$cto :: forall x. Rep TriggerHardFork x -> TriggerHardFork
to :: forall x. Rep TriggerHardFork x -> TriggerHardFork
Generic, Context -> TriggerHardFork -> IO (Maybe ThunkInfo)
Proxy TriggerHardFork -> String
(Context -> TriggerHardFork -> IO (Maybe ThunkInfo))
-> (Context -> TriggerHardFork -> IO (Maybe ThunkInfo))
-> (Proxy TriggerHardFork -> String)
-> NoThunks TriggerHardFork
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> TriggerHardFork -> IO (Maybe ThunkInfo)
noThunks :: Context -> TriggerHardFork -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TriggerHardFork -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TriggerHardFork -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TriggerHardFork -> String
showTypeOf :: Proxy TriggerHardFork -> String
NoThunks)

instance SerialiseNodeToClient blk TriggerHardFork where
  encodeNodeToClient :: CodecConfig blk
-> BlockNodeToClientVersion blk -> TriggerHardFork -> Encoding
encodeNodeToClient CodecConfig blk
_ BlockNodeToClientVersion blk
_ TriggerHardFork
triggerHardFork = case TriggerHardFork
triggerHardFork of
    TriggerHardForkAtVersion Word16
v -> Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
0 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word16 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Word16
v
    TriggerHardForkAtEpoch EpochNo
e   -> Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR EpochNo
e
    TriggerHardFork
TriggerHardForkNotDuringThisExecution -> Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
2
  decodeNodeToClient :: CodecConfig blk
-> BlockNodeToClientVersion blk
-> forall s. Decoder s TriggerHardFork
decodeNodeToClient CodecConfig blk
_ BlockNodeToClientVersion blk
_ = do
    Int
len <- Decoder s Int
forall s. Decoder s Int
decodeListLen
    Word8
tag <- Decoder s Word8
forall s. Decoder s Word8
decodeWord8
    case (Int
len, Word8
tag) of
      (Int
2, Word8
0)   -> Word16 -> TriggerHardFork
TriggerHardForkAtVersion (Word16 -> TriggerHardFork)
-> Decoder s Word16 -> Decoder s TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR @Word16
      (Int
2, Word8
1)   -> EpochNo -> TriggerHardFork
TriggerHardForkAtEpoch (EpochNo -> TriggerHardFork)
-> Decoder s EpochNo -> Decoder s TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. FromCBOR a => Decoder s a
fromCBOR @EpochNo
      (Int
2, Word8
2)   -> TriggerHardFork -> Decoder s TriggerHardFork
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TriggerHardFork
TriggerHardForkNotDuringThisExecution
      (Int, Word8)
_ -> String -> Decoder s TriggerHardFork
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s TriggerHardFork)
-> String -> Decoder s TriggerHardFork
forall a b. (a -> b) -> a -> b
$ String
"TriggerHardFork: invalid (len, tag): " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int, Word8) -> String
forall a. Show a => a -> String
show (Int
len, Word8
tag)