content: {-# LANGUAGE DeriveAnyClass #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DerivingStrategies #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  module Cardano.Chain.Update.ProtocolParameters (
    ProtocolParameters (..),
    upAdptThd,
    isBootstrapEraPP,
  ) where
  
  import Cardano.Chain.Common (
    LovelacePortion,
    TxFeePolicy,
    lovelacePortionToRational,
   )
  import Cardano.Chain.Slotting (EpochNumber, SlotNumber (..), isBootstrapEra)
  import Cardano.Chain.Update.SoftforkRule
  import Cardano.Ledger.Binary (
    DecCBOR (..),
    EncCBOR (..),
    FromCBOR (..),
    ToCBOR (..),
    encodeListLen,
    enforceSize,
    fromByronCBOR,
    toByronCBOR,
   )
  import Cardano.Prelude
  import Formatting (Format, bprint, build, bytes, shortest)
  import qualified Formatting.Buildable as B
  import NoThunks.Class (NoThunks (..))
  import Text.JSON.Canonical (FromJSON (..), ToJSON (..), fromJSField, mkObject)
  
  -- | Data which is associated with 'BlockVersion'
  data ProtocolParameters = ProtocolParameters
    { ppScriptVersion :: !Word16
    , ppSlotDuration :: !Natural
    -- ^ Milliseconds.
    , ppMaxBlockSize :: !Natural
    , ppMaxHeaderSize :: !Natural
    , ppMaxTxSize :: !Natural
    , ppMaxProposalSize :: !Natural
    , ppMpcThd :: !LovelacePortion
    , ppHeavyDelThd :: !LovelacePortion
    , ppUpdateVoteThd :: !LovelacePortion
    , ppUpdateProposalThd :: !LovelacePortion
    , ppUpdateProposalTTL :: !SlotNumber
    -- ^ Time to live for a protocol update proposal. This used to be the number
    -- of slots after which the system made a decision regarding an update
    -- proposal confirmation, when a majority of votes was not reached in the
    -- given number of slots. If there were more positive than negative votes the
    -- proposal became confirmed, otherwise it was rejected. Since in the
    -- Byron-Shelley bridge we do not have negative votes, and we aim at
    -- simplifying the update mechanism, 'ppUpdateProposalTTL' is re-interpreted as
    -- the number of slots a proposal has to gather a majority of votes. If a
    -- majority of votes has not been reached before this period, then the
    -- proposal is rejected.
    --
    -- -- TODO: it seems this should be a slot count.
    , ppSoftforkRule :: !SoftforkRule
    , ppTxFeePolicy :: !TxFeePolicy
    , ppUnlockStakeEpoch :: !EpochNumber
    }
    deriving (Show, Eq, Ord, Generic)
    deriving anyclass (NFData, NoThunks)
  
  instance B.Buildable ProtocolParameters where
    build pp =
      bprint
        ( "{ script version: "
            . build
            . ", slot duration: "
            . bytes'
            . ", block size limit: "
            . bytes'
            . ", header size limit: "
            . bytes'
            . ", tx size limit: "
            . bytes'
            . ", proposal size limit: "
            . bytes'
            . ", mpc threshold: "
            . build
            . ", heavyweight delegation threshold: "
            . build
            . ", update vote threshold: "
            . build
            . ", update proposal threshold: "
            . build
            . ", update implicit period: "
            . build
            . " slots"
            . ", softfork rule: "
            . build
            . ", tx fee policy: "
            . build
            . ", unlock stake epoch: "
            . build
            . " }"
        )
        (ppScriptVersion pp)
        (ppSlotDuration pp)
        (ppMaxBlockSize pp)
        (ppMaxHeaderSize pp)
        (ppMaxTxSize pp)
        (ppMaxProposalSize pp)
        (ppMpcThd pp)
        (ppHeavyDelThd pp)
        (ppUpdateVoteThd pp)
        (ppUpdateProposalThd pp)
        (ppUpdateProposalTTL pp)
        (ppSoftforkRule pp)
        (ppTxFeePolicy pp)
        (ppUnlockStakeEpoch pp)
      where
        bytes' :: Format r (Natural -> r)
        bytes' = bytes (shortest @Double)
  
  instance Monad m => ToJSON m ProtocolParameters where
    toJSON pp =
      mkObject
        [ ("scriptVersion", toJSON $ ppScriptVersion pp)
        , ("slotDuration", toJSON $ ppSlotDuration pp)
        , ("maxBlockSize", toJSON $ ppMaxBlockSize pp)
        , ("maxHeaderSize", toJSON $ ppMaxHeaderSize pp)
        , ("maxTxSize", toJSON $ ppMaxTxSize pp)
        , ("maxProposalSize", toJSON $ ppMaxProposalSize pp)
        , ("mpcThd", toJSON $ ppMpcThd pp)
        , ("heavyDelThd", toJSON $ ppHeavyDelThd pp)
        , ("updateVoteThd", toJSON $ ppUpdateVoteThd pp)
        , ("updateProposalThd", toJSON $ ppUpdateProposalThd pp)
        , ("updateImplicit", toJSON $ ppUpdateProposalTTL pp)
        , ("softforkRule", toJSON $ ppSoftforkRule pp)
        , ("txFeePolicy", toJSON $ ppTxFeePolicy pp)
        , ("unlockStakeEpoch", toJSON $ ppUnlockStakeEpoch pp)
        ]
  
  instance MonadError SchemaError m => FromJSON m ProtocolParameters where
    fromJSON obj =
      ProtocolParameters
        <$> fromJSField obj "scriptVersion"
        <*> fromJSField obj "slotDuration"
        <*> fromJSField obj "maxBlockSize"
        <*> fromJSField obj "maxHeaderSize"
        <*> fromJSField obj "maxTxSize"
        <*> fromJSField obj "maxProposalSize"
        <*> fromJSField obj "mpcThd"
        <*> fromJSField obj "heavyDelThd"
        <*> fromJSField obj "updateVoteThd"
        <*> fromJSField obj "updateProposalThd"
        <*> fromJSField obj "updateImplicit"
        <*> fromJSField obj "softforkRule"
        <*> fromJSField obj "txFeePolicy"
        <*> fromJSField obj "unlockStakeEpoch"
  
  instance ToCBOR ProtocolParameters where
    toCBOR = toByronCBOR
  
  instance FromCBOR ProtocolParameters where
    fromCBOR = fromByronCBOR
  
  instance EncCBOR ProtocolParameters where
    encCBOR pp =
      encodeListLen 14
        <> encCBOR (ppScriptVersion pp)
        <> encCBOR (ppSlotDuration pp)
        <> encCBOR (ppMaxBlockSize pp)
        <> encCBOR (ppMaxHeaderSize pp)
        <> encCBOR (ppMaxTxSize pp)
        <> encCBOR (ppMaxProposalSize pp)
        <> encCBOR (ppMpcThd pp)
        <> encCBOR (ppHeavyDelThd pp)
        <> encCBOR (ppUpdateVoteThd pp)
        <> encCBOR (ppUpdateProposalThd pp)
        <> encCBOR (ppUpdateProposalTTL pp)
        <> encCBOR (ppSoftforkRule pp)
        <> encCBOR (ppTxFeePolicy pp)
        <> encCBOR (ppUnlockStakeEpoch pp)
  
  instance DecCBOR ProtocolParameters where
    decCBOR = do
      enforceSize "ProtocolParameters" 14
      ProtocolParameters
        <$> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
        <*> decCBOR
  
  -- | Version of 'isBootstrapEra' which takes 'ProtocolParameters' instead of
  --   unlock stake epoch
  isBootstrapEraPP :: ProtocolParameters -> EpochNumber -> Bool
  isBootstrapEraPP adoptedPP = isBootstrapEra (ppUnlockStakeEpoch adoptedPP)
  
  -- | In Byron we do not have a @upAdptThd@ protocol parameter, so we have to
  --   use the existing ones.
  --
  --   @lovelacePortionToRational . srMinThd . ppSoftforkRule@ will give us the
  --   ratio (in the interval @[0, 1]@) of the total stake that has to endorse a
  --   protocol version to become adopted. In genesis configuration, this ratio
  --   will evaluate to @0.6@, so if we have 7 genesis keys, @upAdptThd = 4@.
  upAdptThd :: Word8 -> ProtocolParameters -> Int
  upAdptThd numGenKeys pps =
    floor $ stakeRatio * toRational numGenKeys
    where
      stakeRatio = lovelacePortionToRational . srMinThd . ppSoftforkRule $ pps
  