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

module Ouroboros.Consensus.Shelley.Ledger.Query.LegacyShelleyGenesis
  ( 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

-- | 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.
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
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
<> 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