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

module Ouroboros.Consensus.Shelley.Ledger.Query.LegacyShelleyGenesis
  ( LegacyShelleyGenesis (..)
  , encodeLegacyShelleyGenesis
  , decodeLegacyShelleyGenesis
  ) 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 'Genesis) GenDelegPair
ListMap Addr Coin
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 'Genesis) GenDelegPair
sgInitialFunds :: ListMap Addr Coin
sgStaking :: ShelleyGenesisStaking
sgStaking :: ShelleyGenesis -> ShelleyGenesisStaking
sgInitialFunds :: ShelleyGenesis -> ListMap Addr Coin
sgGenDelegs :: ShelleyGenesis -> Map (KeyHash 'Genesis) GenDelegPair
sgProtocolParams :: ShelleyGenesis -> PParams ShelleyEra
sgMaxLovelaceSupply :: ShelleyGenesis -> Word64
sgUpdateQuorum :: ShelleyGenesis -> Word64
sgSlotLength :: ShelleyGenesis -> NominalDiffTimeMicro
sgMaxKESEvolutions :: ShelleyGenesis -> Word64
sgSlotsPerKESPeriod :: ShelleyGenesis -> Word64
sgEpochLength :: ShelleyGenesis -> EpochSize
sgSecurityParam :: ShelleyGenesis -> NonZero Word64
sgActiveSlotsCoeff :: ShelleyGenesis -> PositiveUnitInterval
sgNetworkId :: ShelleyGenesis -> Network
sgNetworkMagic :: ShelleyGenesis -> Word32
sgSystemStart :: ShelleyGenesis -> UTCTime
..
          }
      ) =
      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 'Genesis) GenDelegPair -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'Genesis) 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

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
. Rational -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Rational -> Encoding)
-> (PositiveUnitInterval -> Rational)
-> PositiveUnitInterval
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PositiveUnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational

activeSlotsCoeffDecCBOR :: Decoder s PositiveUnitInterval
activeSlotsCoeffDecCBOR :: forall s. Decoder s PositiveUnitInterval
activeSlotsCoeffDecCBOR = do
  r <- Version -> Decoder s Rational -> Decoder s Rational
forall s a. Version -> Decoder s a -> Decoder s a
enforceDecoderVersion Version
shelleyProtVer (Decoder s Rational -> Decoder s Rational)
-> Decoder s Rational -> Decoder s Rational
forall a b. (a -> b) -> a -> b
$ Decoder s Rational
forall s. Decoder s Rational
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
$ Rational -> String
forall a. Show a => a -> String
show Rational
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