{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Ouroboros.Consensus.Shelley.Ledger.Query.LegacyShelleyGenesis
  ( LegacyShelleyGenesis (..)
  , encodeLegacyShelleyGenesis
  , decodeLegacyShelleyGenesis
  , encodeShelleyGenesisNoExtraConfig
  , decodeShelleyGenesisNoExtraConfig
  ) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Shelley.Genesis
import qualified Data.Text as Text
import Ouroboros.Consensus.Shelley.Ledger.Query.LegacyPParams

-- | The encoding of the PParams changed in node 10.5.
--
-- We can delete this once we cross a HF.
newtype LegacyShelleyGenesis = LegacyShelleyGenesis
  { LegacyShelleyGenesis -> ShelleyGenesis
unLegacyShelleyGenesis :: ShelleyGenesis
  }

encodeLegacyShelleyGenesis :: ShelleyGenesis -> Plain.Encoding
encodeLegacyShelleyGenesis :: ShelleyGenesis -> Encoding
encodeLegacyShelleyGenesis ShelleyGenesis
pp = LegacyShelleyGenesis -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ShelleyGenesis -> LegacyShelleyGenesis
LegacyShelleyGenesis ShelleyGenesis
pp)

decodeLegacyShelleyGenesis :: Plain.Decoder s ShelleyGenesis
decodeLegacyShelleyGenesis :: forall s. Decoder s ShelleyGenesis
decodeLegacyShelleyGenesis = LegacyShelleyGenesis -> ShelleyGenesis
unLegacyShelleyGenesis (LegacyShelleyGenesis -> ShelleyGenesis)
-> Decoder s LegacyShelleyGenesis -> Decoder s ShelleyGenesis
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s LegacyShelleyGenesis
forall s. Decoder s LegacyShelleyGenesis
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance ToCBOR LegacyShelleyGenesis where
  toCBOR :: LegacyShelleyGenesis -> Encoding
toCBOR
    ( LegacyShelleyGenesis
        ShelleyGenesis
          { Word32
Word64
UTCTime
Map (KeyHash GenesisRole) GenDelegPair
ListMap Addr Coin
StrictMaybe ShelleyExtraConfig
PParams ShelleyEra
EpochSize
NonZero Word64
Network
PositiveUnitInterval
NominalDiffTimeMicro
ShelleyGenesisStaking
sgSystemStart :: UTCTime
sgNetworkMagic :: Word32
sgNetworkId :: Network
sgActiveSlotsCoeff :: PositiveUnitInterval
sgSecurityParam :: NonZero Word64
sgEpochLength :: EpochSize
sgSlotsPerKESPeriod :: Word64
sgMaxKESEvolutions :: Word64
sgSlotLength :: NominalDiffTimeMicro
sgUpdateQuorum :: Word64
sgMaxLovelaceSupply :: Word64
sgProtocolParams :: PParams ShelleyEra
sgGenDelegs :: Map (KeyHash GenesisRole) GenDelegPair
sgInitialFunds :: ListMap Addr Coin
sgStaking :: ShelleyGenesisStaking
sgExtraConfig :: StrictMaybe ShelleyExtraConfig
sgActiveSlotsCoeff :: ShelleyGenesis -> PositiveUnitInterval
sgEpochLength :: ShelleyGenesis -> EpochSize
sgExtraConfig :: ShelleyGenesis -> StrictMaybe ShelleyExtraConfig
sgGenDelegs :: ShelleyGenesis -> Map (KeyHash GenesisRole) GenDelegPair
sgInitialFunds :: ShelleyGenesis -> ListMap Addr Coin
sgMaxKESEvolutions :: ShelleyGenesis -> Word64
sgMaxLovelaceSupply :: ShelleyGenesis -> Word64
sgNetworkId :: ShelleyGenesis -> Network
sgNetworkMagic :: ShelleyGenesis -> Word32
sgProtocolParams :: ShelleyGenesis -> PParams ShelleyEra
sgSecurityParam :: ShelleyGenesis -> NonZero Word64
sgSlotLength :: ShelleyGenesis -> NominalDiffTimeMicro
sgSlotsPerKESPeriod :: ShelleyGenesis -> Word64
sgStaking :: ShelleyGenesis -> ShelleyGenesisStaking
sgSystemStart :: ShelleyGenesis -> UTCTime
sgUpdateQuorum :: ShelleyGenesis -> Word64
..
          }
      ) =
      Version -> Encoding -> Encoding
toPlainEncoding Version
shelleyProtVer (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$
        Word -> Encoding
encodeListLen Word
15
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTCTime -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR UTCTime
sgSystemStart
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word32
sgNetworkMagic
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Network
sgNetworkId
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PositiveUnitInterval -> Encoding
activeSlotsCoeffEncCBOR PositiveUnitInterval
sgActiveSlotsCoeff
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NonZero Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR NonZero Word64
sgSecurityParam
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (EpochSize -> Word64
unEpochSize EpochSize
sgEpochLength)
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgSlotsPerKESPeriod
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgMaxKESEvolutions
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NominalDiffTimeMicro -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR NominalDiffTimeMicro
sgSlotLength
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgUpdateQuorum
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgMaxLovelaceSupply
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LegacyPParams ShelleyEra -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (PParams ShelleyEra -> LegacyPParams ShelleyEra
forall era. PParams era -> LegacyPParams era
LegacyPParams PParams ShelleyEra
sgProtocolParams)
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash GenesisRole) GenDelegPair -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash GenesisRole) GenDelegPair
sgGenDelegs
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ListMap Addr Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ListMap Addr Coin
sgInitialFunds
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ShelleyGenesisStaking -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ShelleyGenesisStaking
sgStaking

instance FromCBOR LegacyShelleyGenesis where
  fromCBOR :: forall s. Decoder s LegacyShelleyGenesis
fromCBOR = Maybe ByteString
-> Version
-> Decoder s LegacyShelleyGenesis
-> Decoder s LegacyShelleyGenesis
forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder Maybe ByteString
forall a. Maybe a
Nothing Version
shelleyProtVer (Decoder s LegacyShelleyGenesis -> Decoder s LegacyShelleyGenesis)
-> Decoder s LegacyShelleyGenesis -> Decoder s LegacyShelleyGenesis
forall a b. (a -> b) -> a -> b
$ do
    Text
-> (LegacyShelleyGenesis -> Int)
-> Decoder s LegacyShelleyGenesis
-> Decoder s LegacyShelleyGenesis
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyGenesis" (Int -> LegacyShelleyGenesis -> Int
forall a b. a -> b -> a
const Int
15) (Decoder s LegacyShelleyGenesis -> Decoder s LegacyShelleyGenesis)
-> Decoder s LegacyShelleyGenesis -> Decoder s LegacyShelleyGenesis
forall a b. (a -> b) -> a -> b
$ do
      sgSystemStart <- Decoder s UTCTime
forall s. Decoder s UTCTime
forall a s. DecCBOR a => Decoder s a
decCBOR
      sgNetworkMagic <- decCBOR
      sgNetworkId <- decCBOR
      sgActiveSlotsCoeff <- activeSlotsCoeffDecCBOR
      sgSecurityParam <- decCBOR
      sgEpochLength <- decCBOR
      sgSlotsPerKESPeriod <- decCBOR
      sgMaxKESEvolutions <- decCBOR
      sgSlotLength <- decCBOR
      sgUpdateQuorum <- decCBOR
      sgMaxLovelaceSupply <- decCBOR
      (LegacyPParams sgProtocolParams) <- decCBOR
      sgGenDelegs <- decCBOR
      sgInitialFunds <- decCBOR
      sgStaking <- decCBOR
      pure $
        LegacyShelleyGenesis $
          ShelleyGenesis
            sgSystemStart
            sgNetworkMagic
            sgNetworkId
            sgActiveSlotsCoeff
            sgSecurityParam
            (EpochSize sgEpochLength)
            sgSlotsPerKESPeriod
            sgMaxKESEvolutions
            sgSlotLength
            sgUpdateQuorum
            sgMaxLovelaceSupply
            sgProtocolParams
            sgGenDelegs
            sgInitialFunds
            sgStaking
            SNothing

-- | Encode 'ShelleyGenesis' with 15 fields, and drop @sgExtraConfig@.
--
-- cardano-ledger-shelley 1.19.0.0 added @sgExtraConfig@ and grew the CBOR record
-- from 15 fields to 16, with no version guard.
-- This codec keeps the 15-field encoding of cardano-ledger-shelley 1.18.
--
-- 'Ouroboros.Consensus.Shelley.Ledger.Config.compactGenesis' erases
-- @sgExtraConfig@, so the query answer never carries a value for it.
--
-- 'encodeLegacyShelleyGenesis' also writes 15 fields, but with the
-- 'LegacyPParams' encoding from before node 10.5.
encodeShelleyGenesisNoExtraConfig :: ShelleyGenesis -> Plain.Encoding
encodeShelleyGenesisNoExtraConfig :: ShelleyGenesis -> Encoding
encodeShelleyGenesisNoExtraConfig
  ShelleyGenesis
    { Word32
Word64
UTCTime
Map (KeyHash GenesisRole) GenDelegPair
ListMap Addr Coin
StrictMaybe ShelleyExtraConfig
PParams ShelleyEra
EpochSize
NonZero Word64
Network
PositiveUnitInterval
NominalDiffTimeMicro
ShelleyGenesisStaking
sgActiveSlotsCoeff :: ShelleyGenesis -> PositiveUnitInterval
sgEpochLength :: ShelleyGenesis -> EpochSize
sgExtraConfig :: ShelleyGenesis -> StrictMaybe ShelleyExtraConfig
sgGenDelegs :: ShelleyGenesis -> Map (KeyHash GenesisRole) GenDelegPair
sgInitialFunds :: ShelleyGenesis -> ListMap Addr Coin
sgMaxKESEvolutions :: ShelleyGenesis -> Word64
sgMaxLovelaceSupply :: ShelleyGenesis -> Word64
sgNetworkId :: ShelleyGenesis -> Network
sgNetworkMagic :: ShelleyGenesis -> Word32
sgProtocolParams :: ShelleyGenesis -> PParams ShelleyEra
sgSecurityParam :: ShelleyGenesis -> NonZero Word64
sgSlotLength :: ShelleyGenesis -> NominalDiffTimeMicro
sgSlotsPerKESPeriod :: ShelleyGenesis -> Word64
sgStaking :: ShelleyGenesis -> ShelleyGenesisStaking
sgSystemStart :: ShelleyGenesis -> UTCTime
sgUpdateQuorum :: ShelleyGenesis -> Word64
sgSystemStart :: UTCTime
sgNetworkMagic :: Word32
sgNetworkId :: Network
sgActiveSlotsCoeff :: PositiveUnitInterval
sgSecurityParam :: NonZero Word64
sgEpochLength :: EpochSize
sgSlotsPerKESPeriod :: Word64
sgMaxKESEvolutions :: Word64
sgSlotLength :: NominalDiffTimeMicro
sgUpdateQuorum :: Word64
sgMaxLovelaceSupply :: Word64
sgProtocolParams :: PParams ShelleyEra
sgGenDelegs :: Map (KeyHash GenesisRole) GenDelegPair
sgInitialFunds :: ListMap Addr Coin
sgStaking :: ShelleyGenesisStaking
sgExtraConfig :: StrictMaybe ShelleyExtraConfig
..
    } =
    Version -> Encoding -> Encoding
toPlainEncoding Version
shelleyProtVer (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$
      Word -> Encoding
encodeListLen Word
15
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTCTime -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR UTCTime
sgSystemStart
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word32
sgNetworkMagic
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Network
sgNetworkId
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PositiveUnitInterval -> Encoding
activeSlotsCoeffEncCBOR PositiveUnitInterval
sgActiveSlotsCoeff
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NonZero Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR NonZero Word64
sgSecurityParam
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (EpochSize -> Word64
unEpochSize EpochSize
sgEpochLength)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgSlotsPerKESPeriod
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgMaxKESEvolutions
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NominalDiffTimeMicro -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR NominalDiffTimeMicro
sgSlotLength
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgUpdateQuorum
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word64
sgMaxLovelaceSupply
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PParams ShelleyEra -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR PParams ShelleyEra
sgProtocolParams
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash GenesisRole) GenDelegPair -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash GenesisRole) GenDelegPair
sgGenDelegs
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ListMap Addr Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ListMap Addr Coin
sgInitialFunds
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ShelleyGenesisStaking -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ShelleyGenesisStaking
sgStaking

-- | Decode 'ShelleyGenesis' from the 15 fields written by
-- 'encodeShelleyGenesisNoExtraConfig'.
decodeShelleyGenesisNoExtraConfig :: Plain.Decoder s ShelleyGenesis
decodeShelleyGenesisNoExtraConfig :: forall s. Decoder s ShelleyGenesis
decodeShelleyGenesisNoExtraConfig = Maybe ByteString
-> Version -> Decoder s ShelleyGenesis -> Decoder s ShelleyGenesis
forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder Maybe ByteString
forall a. Maybe a
Nothing Version
shelleyProtVer (Decoder s ShelleyGenesis -> Decoder s ShelleyGenesis)
-> Decoder s ShelleyGenesis -> Decoder s ShelleyGenesis
forall a b. (a -> b) -> a -> b
$
  Text
-> (ShelleyGenesis -> Int)
-> Decoder s ShelleyGenesis
-> Decoder s ShelleyGenesis
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyGenesis" (Int -> ShelleyGenesis -> Int
forall a b. a -> b -> a
const Int
15) (Decoder s ShelleyGenesis -> Decoder s ShelleyGenesis)
-> Decoder s ShelleyGenesis -> Decoder s ShelleyGenesis
forall a b. (a -> b) -> a -> b
$ do
    sgSystemStart <- Decoder s UTCTime
forall s. Decoder s UTCTime
forall a s. DecCBOR a => Decoder s a
decCBOR
    sgNetworkMagic <- decCBOR
    sgNetworkId <- decCBOR
    sgActiveSlotsCoeff <- activeSlotsCoeffDecCBOR
    sgSecurityParam <- decCBOR
    sgEpochLength <- decCBOR
    sgSlotsPerKESPeriod <- decCBOR
    sgMaxKESEvolutions <- decCBOR
    sgSlotLength <- decCBOR
    sgUpdateQuorum <- decCBOR
    sgMaxLovelaceSupply <- decCBOR
    sgProtocolParams <- decCBOR
    sgGenDelegs <- decCBOR
    sgInitialFunds <- decCBOR
    sgStaking <- decCBOR
    let sgExtraConfig = StrictMaybe a
forall a. StrictMaybe a
SNothing
    pure $
      ShelleyGenesis
        sgSystemStart
        sgNetworkMagic
        sgNetworkId
        sgActiveSlotsCoeff
        sgSecurityParam
        (EpochSize sgEpochLength)
        sgSlotsPerKESPeriod
        sgMaxKESEvolutions
        sgSlotLength
        sgUpdateQuorum
        sgMaxLovelaceSupply
        sgProtocolParams
        sgGenDelegs
        sgInitialFunds
        sgStaking
        sgExtraConfig

activeSlotsCoeffEncCBOR :: PositiveUnitInterval -> Encoding
activeSlotsCoeffEncCBOR :: PositiveUnitInterval -> Encoding
activeSlotsCoeffEncCBOR = Version -> Encoding -> Encoding
enforceEncodingVersion Version
shelleyProtVer (Encoding -> Encoding)
-> (PositiveUnitInterval -> Encoding)
-> PositiveUnitInterval
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Integer -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Ratio Integer -> Encoding)
-> (PositiveUnitInterval -> Ratio Integer)
-> PositiveUnitInterval
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositiveUnitInterval -> Ratio Integer
forall r. BoundedRational r => r -> Ratio Integer
unboundRational

activeSlotsCoeffDecCBOR :: Decoder s PositiveUnitInterval
activeSlotsCoeffDecCBOR :: forall s. Decoder s PositiveUnitInterval
activeSlotsCoeffDecCBOR = do
  r <- Version -> Decoder s (Ratio Integer) -> Decoder s (Ratio Integer)
forall s a. Version -> Decoder s a -> Decoder s a
enforceDecoderVersion Version
shelleyProtVer (Decoder s (Ratio Integer) -> Decoder s (Ratio Integer))
-> Decoder s (Ratio Integer) -> Decoder s (Ratio Integer)
forall a b. (a -> b) -> a -> b
$ Decoder s (Ratio Integer)
forall s. Decoder s (Ratio Integer)
decodeRational
  case boundRational r of
    Maybe PositiveUnitInterval
Nothing ->
      DecoderError -> Decoder s PositiveUnitInterval
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s PositiveUnitInterval)
-> DecoderError -> Decoder s PositiveUnitInterval
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"ActiveSlotsCoeff (PositiveUnitInterval)" (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> String
forall a. Show a => a -> String
show Ratio Integer
r)
    Just PositiveUnitInterval
u -> PositiveUnitInterval -> Decoder s PositiveUnitInterval
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PositiveUnitInterval
u