{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.Genesis (
  ShelleyGenesisStaking (..),
  ShelleyGenesis (..),
  toShelleyGenesisPairs,
  ValidationErr (..),
  NominalDiffTimeMicro (..),
  emptyGenesisStaking,
  sgActiveSlotCoeff,
  genesisUTxO,
  initialFundsPseudoTxIn,
  validateGenesis,
  describeValidationErr,
  mkShelleyGlobals,
  nominalDiffTimeMicroToMicroseconds,
  nominalDiffTimeMicroToSeconds,
  toNominalDiffTimeMicro,
  toNominalDiffTimeMicroWithRounding,
  fromNominalDiffTimeMicro,
  secondsToNominalDiffTimeMicro,
  sgInitialFundsL,
  sgStakingL,
)
where

import Cardano.Crypto.DSIGN (Ed25519DSIGN)
import Cardano.Crypto.Hash (Blake2b_256)
import qualified Cardano.Crypto.Hash.Class as H
import Cardano.Crypto.KES (Sum6KES, totalPeriodsKES)
import Cardano.Ledger.Address (Addr, serialiseAddr)
import Cardano.Ledger.BaseTypes (
  ActiveSlotCoeff,
  BoundedRational (boundRational, unboundRational),
  EpochSize (..),
  Globals (..),
  Network,
  NonZero (..),
  Nonce (..),
  PositiveUnitInterval,
  mkActiveSlotCoeff,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  Decoder,
  DecoderError (..),
  EncCBOR (..),
  Encoding,
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeRational,
  decodeRecordNamed,
  encodeListLen,
  enforceDecoderVersion,
  enforceEncodingVersion,
  shelleyProtVer,
  toPlainDecoder,
  toPlainEncoding,
 )
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Core
import Cardano.Ledger.Genesis (EraGenesis (..))
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
import Cardano.Ledger.Keys
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams (ShelleyPParams (..))
import Cardano.Ledger.Shelley.StabilityWindow
import Cardano.Ledger.State (UTxO (UTxO))
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import qualified Cardano.Ledger.Val as Val
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart (SystemStart))
import Control.Monad.Identity (Identity)
import Data.Aeson (FromJSON (..), ToJSON (..), object, (.!=), (.:), (.:?), (.=))
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Parser, Value (..), typeMismatch)
import Data.Fixed (Fixed (..), Micro, Pico)
import qualified Data.ListMap as LM
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Clock (
  NominalDiffTime,
  UTCTime (..),
  nominalDiffTimeToSeconds,
  secondsToNominalDiffTime,
 )
import Data.Unit.Strict (forceElemsToWHNF)
import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens)
import NoThunks.Class (AllowThunksIn (..), NoThunks (..))

-- | Genesis Shelley staking configuration.
--
-- This allows us to configure some initial stake pools and delegation to them,
-- in order to test Praos in a static configuration, without requiring on-chain
-- registration and delegation.
--
-- For simplicity, pools defined in the genesis staking do not pay deposits for
-- their registration.
data ShelleyGenesisStaking = ShelleyGenesisStaking
  { ShelleyGenesisStaking -> ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: LM.ListMap (KeyHash 'StakePool) PoolParams
  -- ^ Pools to register
  --
  --   The key in this map is the hash of the public key of the _pool_. This
  --   need not correspond to any payment or staking key, but must correspond
  --   to the cold key held by 'TPraosIsCoreNode'.
  , ShelleyGenesisStaking
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: LM.ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
  -- ^ Stake-holding key hash credentials and the pools to delegate that stake
  -- to. We require the raw staking key hash in order to:
  --
  -- - Avoid pointer addresses, which would be tricky when there's no slot or
  --   transaction to point to.
  -- - Avoid script credentials.
  }
  deriving stock (ShelleyGenesisStaking -> ShelleyGenesisStaking -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleyGenesisStaking -> ShelleyGenesisStaking -> Bool
$c/= :: ShelleyGenesisStaking -> ShelleyGenesisStaking -> Bool
== :: ShelleyGenesisStaking -> ShelleyGenesisStaking -> Bool
$c== :: ShelleyGenesisStaking -> ShelleyGenesisStaking -> Bool
Eq, Int -> ShelleyGenesisStaking -> ShowS
[ShelleyGenesisStaking] -> ShowS
ShelleyGenesisStaking -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyGenesisStaking] -> ShowS
$cshowList :: [ShelleyGenesisStaking] -> ShowS
show :: ShelleyGenesisStaking -> String
$cshow :: ShelleyGenesisStaking -> String
showsPrec :: Int -> ShelleyGenesisStaking -> ShowS
$cshowsPrec :: Int -> ShelleyGenesisStaking -> ShowS
Show, forall x. Rep ShelleyGenesisStaking x -> ShelleyGenesisStaking
forall x. ShelleyGenesisStaking -> Rep ShelleyGenesisStaking x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShelleyGenesisStaking x -> ShelleyGenesisStaking
$cfrom :: forall x. ShelleyGenesisStaking -> Rep ShelleyGenesisStaking x
Generic)

instance NoThunks ShelleyGenesisStaking

instance Semigroup ShelleyGenesisStaking where
  <> :: ShelleyGenesisStaking
-> ShelleyGenesisStaking -> ShelleyGenesisStaking
(<>) (ShelleyGenesisStaking ListMap (KeyHash 'StakePool) PoolParams
p1 ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
s1) (ShelleyGenesisStaking ListMap (KeyHash 'StakePool) PoolParams
p2 ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
s2) =
    ListMap (KeyHash 'StakePool) PoolParams
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
-> ShelleyGenesisStaking
ShelleyGenesisStaking (ListMap (KeyHash 'StakePool) PoolParams
p1 forall a. Semigroup a => a -> a -> a
<> ListMap (KeyHash 'StakePool) PoolParams
p2) (ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
s1 forall a. Semigroup a => a -> a -> a
<> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
s2)

instance Monoid ShelleyGenesisStaking where
  mempty :: ShelleyGenesisStaking
mempty = ListMap (KeyHash 'StakePool) PoolParams
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
-> ShelleyGenesisStaking
ShelleyGenesisStaking forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

instance EncCBOR ShelleyGenesisStaking where
  encCBOR :: ShelleyGenesisStaking -> Encoding
encCBOR (ShelleyGenesisStaking ListMap (KeyHash 'StakePool) PoolParams
pools ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
stake) =
    Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ListMap (KeyHash 'StakePool) PoolParams
pools forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
stake

instance DecCBOR ShelleyGenesisStaking where
  decCBOR :: forall s. Decoder s ShelleyGenesisStaking
decCBOR = do
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyGenesisStaking" (forall a b. a -> b -> a
const Int
2) forall a b. (a -> b) -> a -> b
$ do
      ListMap (KeyHash 'StakePool) PoolParams
pools <- forall a s. DecCBOR a => Decoder s a
decCBOR
      ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
stake <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ListMap (KeyHash 'StakePool) PoolParams
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
-> ShelleyGenesisStaking
ShelleyGenesisStaking ListMap (KeyHash 'StakePool) PoolParams
pools ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
stake

-- | Empty genesis staking
emptyGenesisStaking :: ShelleyGenesisStaking
emptyGenesisStaking :: ShelleyGenesisStaking
emptyGenesisStaking = forall a. Monoid a => a
mempty

-- | Unlike @'NominalDiffTime'@ that supports @'Pico'@ precision, this type
-- only supports @'Micro'@ precision.
newtype NominalDiffTimeMicro = NominalDiffTimeMicro Micro
  deriving (Int -> NominalDiffTimeMicro -> ShowS
[NominalDiffTimeMicro] -> ShowS
NominalDiffTimeMicro -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NominalDiffTimeMicro] -> ShowS
$cshowList :: [NominalDiffTimeMicro] -> ShowS
show :: NominalDiffTimeMicro -> String
$cshow :: NominalDiffTimeMicro -> String
showsPrec :: Int -> NominalDiffTimeMicro -> ShowS
$cshowsPrec :: Int -> NominalDiffTimeMicro -> ShowS
Show, NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
$c/= :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
== :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
$c== :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
Eq, forall x. Rep NominalDiffTimeMicro x -> NominalDiffTimeMicro
forall x. NominalDiffTimeMicro -> Rep NominalDiffTimeMicro x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NominalDiffTimeMicro x -> NominalDiffTimeMicro
$cfrom :: forall x. NominalDiffTimeMicro -> Rep NominalDiffTimeMicro x
Generic)
  deriving anyclass (Context -> NominalDiffTimeMicro -> IO (Maybe ThunkInfo)
Proxy NominalDiffTimeMicro -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy NominalDiffTimeMicro -> String
$cshowTypeOf :: Proxy NominalDiffTimeMicro -> String
wNoThunks :: Context -> NominalDiffTimeMicro -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> NominalDiffTimeMicro -> IO (Maybe ThunkInfo)
noThunks :: Context -> NominalDiffTimeMicro -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> NominalDiffTimeMicro -> IO (Maybe ThunkInfo)
NoThunks)
  deriving newtype (Eq NominalDiffTimeMicro
NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
NominalDiffTimeMicro -> NominalDiffTimeMicro -> Ordering
NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
$cmin :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
max :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
$cmax :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
>= :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
$c>= :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
> :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
$c> :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
<= :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
$c<= :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
< :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
$c< :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Bool
compare :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Ordering
$ccompare :: NominalDiffTimeMicro -> NominalDiffTimeMicro -> Ordering
Ord, Integer -> NominalDiffTimeMicro
NominalDiffTimeMicro -> NominalDiffTimeMicro
NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> NominalDiffTimeMicro
$cfromInteger :: Integer -> NominalDiffTimeMicro
signum :: NominalDiffTimeMicro -> NominalDiffTimeMicro
$csignum :: NominalDiffTimeMicro -> NominalDiffTimeMicro
abs :: NominalDiffTimeMicro -> NominalDiffTimeMicro
$cabs :: NominalDiffTimeMicro -> NominalDiffTimeMicro
negate :: NominalDiffTimeMicro -> NominalDiffTimeMicro
$cnegate :: NominalDiffTimeMicro -> NominalDiffTimeMicro
* :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
$c* :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
- :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
$c- :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
+ :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
$c+ :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
Num, Num NominalDiffTimeMicro
Rational -> NominalDiffTimeMicro
NominalDiffTimeMicro -> NominalDiffTimeMicro
NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> NominalDiffTimeMicro
$cfromRational :: Rational -> NominalDiffTimeMicro
recip :: NominalDiffTimeMicro -> NominalDiffTimeMicro
$crecip :: NominalDiffTimeMicro -> NominalDiffTimeMicro
/ :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
$c/ :: NominalDiffTimeMicro
-> NominalDiffTimeMicro -> NominalDiffTimeMicro
Fractional, Num NominalDiffTimeMicro
Ord NominalDiffTimeMicro
NominalDiffTimeMicro -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: NominalDiffTimeMicro -> Rational
$ctoRational :: NominalDiffTimeMicro -> Rational
Real, [NominalDiffTimeMicro] -> Encoding
[NominalDiffTimeMicro] -> Value
NominalDiffTimeMicro -> Bool
NominalDiffTimeMicro -> Encoding
NominalDiffTimeMicro -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: NominalDiffTimeMicro -> Bool
$comitField :: NominalDiffTimeMicro -> Bool
toEncodingList :: [NominalDiffTimeMicro] -> Encoding
$ctoEncodingList :: [NominalDiffTimeMicro] -> Encoding
toJSONList :: [NominalDiffTimeMicro] -> Value
$ctoJSONList :: [NominalDiffTimeMicro] -> Value
toEncoding :: NominalDiffTimeMicro -> Encoding
$ctoEncoding :: NominalDiffTimeMicro -> Encoding
toJSON :: NominalDiffTimeMicro -> Value
$ctoJSON :: NominalDiffTimeMicro -> Value
ToJSON, Maybe NominalDiffTimeMicro
Value -> Parser [NominalDiffTimeMicro]
Value -> Parser NominalDiffTimeMicro
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe NominalDiffTimeMicro
$comittedField :: Maybe NominalDiffTimeMicro
parseJSONList :: Value -> Parser [NominalDiffTimeMicro]
$cparseJSONList :: Value -> Parser [NominalDiffTimeMicro]
parseJSON :: Value -> Parser NominalDiffTimeMicro
$cparseJSON :: Value -> Parser NominalDiffTimeMicro
FromJSON, Typeable NominalDiffTimeMicro
NominalDiffTimeMicro -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [NominalDiffTimeMicro] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy NominalDiffTimeMicro -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [NominalDiffTimeMicro] -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [NominalDiffTimeMicro] -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy NominalDiffTimeMicro -> Size
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy NominalDiffTimeMicro -> Size
encCBOR :: NominalDiffTimeMicro -> Encoding
$cencCBOR :: NominalDiffTimeMicro -> Encoding
EncCBOR, Typeable NominalDiffTimeMicro
Proxy NominalDiffTimeMicro -> Text
forall s. Decoder s NominalDiffTimeMicro
forall a.
Typeable a
-> (forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy NominalDiffTimeMicro -> Decoder s ()
label :: Proxy NominalDiffTimeMicro -> Text
$clabel :: Proxy NominalDiffTimeMicro -> Text
dropCBOR :: forall s. Proxy NominalDiffTimeMicro -> Decoder s ()
$cdropCBOR :: forall s. Proxy NominalDiffTimeMicro -> Decoder s ()
decCBOR :: forall s. Decoder s NominalDiffTimeMicro
$cdecCBOR :: forall s. Decoder s NominalDiffTimeMicro
DecCBOR)

-- | There is no loss of resolution in this conversion
microToPico :: Micro -> Pico
microToPico :: Micro -> Pico
microToPico Micro
micro = forall a. Fractional a => Rational -> a
fromRational @Pico forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Micro
micro

-- | Loss of resolution occurs in this conversion
picoToMicro :: Pico -> Micro
picoToMicro :: Pico -> Micro
picoToMicro Pico
pico = forall a. Fractional a => Rational -> a
fromRational @Micro forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational Pico
pico

fromNominalDiffTimeMicro :: NominalDiffTimeMicro -> NominalDiffTime
fromNominalDiffTimeMicro :: NominalDiffTimeMicro -> NominalDiffTime
fromNominalDiffTimeMicro =
  Pico -> NominalDiffTime
secondsToNominalDiffTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> Pico
microToPico forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTimeMicro -> Micro
nominalDiffTimeMicroToMicroseconds

toNominalDiffTimeMicroWithRounding :: NominalDiffTime -> NominalDiffTimeMicro
toNominalDiffTimeMicroWithRounding :: NominalDiffTime -> NominalDiffTimeMicro
toNominalDiffTimeMicroWithRounding =
  Micro -> NominalDiffTimeMicro
secondsToNominalDiffTimeMicro forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Micro
picoToMicro forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds

toNominalDiffTimeMicro :: NominalDiffTime -> Maybe NominalDiffTimeMicro
toNominalDiffTimeMicro :: NominalDiffTime -> Maybe NominalDiffTimeMicro
toNominalDiffTimeMicro NominalDiffTime
ndt
  | NominalDiffTimeMicro -> NominalDiffTime
fromNominalDiffTimeMicro NominalDiffTimeMicro
ndtm forall a. Eq a => a -> a -> Bool
== NominalDiffTime
ndt = forall a. a -> Maybe a
Just NominalDiffTimeMicro
ndtm
  | Bool
otherwise = forall a. Maybe a
Nothing
  where
    ndtm :: NominalDiffTimeMicro
ndtm = NominalDiffTime -> NominalDiffTimeMicro
toNominalDiffTimeMicroWithRounding NominalDiffTime
ndt

secondsToNominalDiffTimeMicro :: Micro -> NominalDiffTimeMicro
secondsToNominalDiffTimeMicro :: Micro -> NominalDiffTimeMicro
secondsToNominalDiffTimeMicro = Micro -> NominalDiffTimeMicro
NominalDiffTimeMicro

nominalDiffTimeMicroToMicroseconds :: NominalDiffTimeMicro -> Micro
nominalDiffTimeMicroToMicroseconds :: NominalDiffTimeMicro -> Micro
nominalDiffTimeMicroToMicroseconds (NominalDiffTimeMicro Micro
microseconds) = Micro
microseconds

nominalDiffTimeMicroToSeconds :: NominalDiffTimeMicro -> Pico
nominalDiffTimeMicroToSeconds :: NominalDiffTimeMicro -> Pico
nominalDiffTimeMicroToSeconds (NominalDiffTimeMicro Micro
microseconds) = Micro -> Pico
microToPico Micro
microseconds

-- | Shelley genesis information
--
-- Note that this is needed only for a pure Shelley network, hence it being
-- defined here rather than in its own module. In mainnet, Shelley will
-- transition naturally from Byron, and thus will never have its own genesis
-- information.
data ShelleyGenesis = ShelleyGenesis
  { ShelleyGenesis -> UTCTime
sgSystemStart :: !UTCTime
  , ShelleyGenesis -> Word32
sgNetworkMagic :: !Word32
  , ShelleyGenesis -> Network
sgNetworkId :: !Network
  , ShelleyGenesis -> PositiveUnitInterval
sgActiveSlotsCoeff :: !PositiveUnitInterval
  , ShelleyGenesis -> NonZero Word64
sgSecurityParam :: !(NonZero Word64)
  , ShelleyGenesis -> EpochSize
sgEpochLength :: !EpochSize
  , ShelleyGenesis -> Word64
sgSlotsPerKESPeriod :: !Word64
  , ShelleyGenesis -> Word64
sgMaxKESEvolutions :: !Word64
  , ShelleyGenesis -> NominalDiffTimeMicro
sgSlotLength :: !NominalDiffTimeMicro
  , ShelleyGenesis -> Word64
sgUpdateQuorum :: !Word64
  , ShelleyGenesis -> Word64
sgMaxLovelaceSupply :: !Word64
  , ShelleyGenesis -> PParams ShelleyEra
sgProtocolParams :: !(PParams ShelleyEra)
  , ShelleyGenesis -> Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs :: !(Map (KeyHash 'Genesis) GenDelegPair)
  , ShelleyGenesis -> ListMap Addr Coin
sgInitialFunds :: LM.ListMap Addr Coin
  -- ^ 'sgInitialFunds' is intentionally kept lazy, as it can otherwise cause
  --   out-of-memory problems in testing and benchmarking.
  , ShelleyGenesis -> ShelleyGenesisStaking
sgStaking :: ShelleyGenesisStaking
  -- ^ 'sgStaking' is intentionally kept lazy, as it can otherwise cause
  --   out-of-memory problems in testing and benchmarking.
  }
  deriving stock (forall x. Rep ShelleyGenesis x -> ShelleyGenesis
forall x. ShelleyGenesis -> Rep ShelleyGenesis x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShelleyGenesis x -> ShelleyGenesis
$cfrom :: forall x. ShelleyGenesis -> Rep ShelleyGenesis x
Generic, Int -> ShelleyGenesis -> ShowS
[ShelleyGenesis] -> ShowS
ShelleyGenesis -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyGenesis] -> ShowS
$cshowList :: [ShelleyGenesis] -> ShowS
show :: ShelleyGenesis -> String
$cshow :: ShelleyGenesis -> String
showsPrec :: Int -> ShelleyGenesis -> ShowS
$cshowsPrec :: Int -> ShelleyGenesis -> ShowS
Show, ShelleyGenesis -> ShelleyGenesis -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleyGenesis -> ShelleyGenesis -> Bool
$c/= :: ShelleyGenesis -> ShelleyGenesis -> Bool
== :: ShelleyGenesis -> ShelleyGenesis -> Bool
$c== :: ShelleyGenesis -> ShelleyGenesis -> Bool
Eq)

sgInitialFundsL :: Lens' ShelleyGenesis (LM.ListMap Addr Coin)
sgInitialFundsL :: Lens' ShelleyGenesis (ListMap Addr Coin)
sgInitialFundsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyGenesis -> ListMap Addr Coin
sgInitialFunds (\ShelleyGenesis
sg ListMap Addr Coin
x -> ShelleyGenesis
sg {sgInitialFunds :: ListMap Addr Coin
sgInitialFunds = ListMap Addr Coin
x})

sgStakingL :: Lens' ShelleyGenesis ShelleyGenesisStaking
sgStakingL :: Lens' ShelleyGenesis ShelleyGenesisStaking
sgStakingL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyGenesis -> ShelleyGenesisStaking
sgStaking (\ShelleyGenesis
sg ShelleyGenesisStaking
x -> ShelleyGenesis
sg {sgStaking :: ShelleyGenesisStaking
sgStaking = ShelleyGenesisStaking
x})

deriving via
  AllowThunksIn '["sgInitialFunds", "sgStaking"] ShelleyGenesis
  instance
    NoThunks ShelleyGenesis

sgActiveSlotCoeff :: ShelleyGenesis -> ActiveSlotCoeff
sgActiveSlotCoeff :: ShelleyGenesis -> ActiveSlotCoeff
sgActiveSlotCoeff = PositiveUnitInterval -> ActiveSlotCoeff
mkActiveSlotCoeff forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis -> PositiveUnitInterval
sgActiveSlotsCoeff

instance ToJSON ShelleyGenesis where
  toJSON :: ShelleyGenesis -> Value
toJSON = [Pair] -> Value
Aeson.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => ShelleyGenesis -> [a]
toShelleyGenesisPairs
  toEncoding :: ShelleyGenesis -> Encoding
toEncoding = Series -> Encoding
Aeson.pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => ShelleyGenesis -> [a]
toShelleyGenesisPairs

instance EraGenesis ShelleyEra where
  type Genesis ShelleyEra = ShelleyGenesis

--------------------------------------------------
-- Legacy JSON representation of ShelleyGenesis --
--------------------------------------------------
newtype LegacyJSONPParams = LegacyJSONPParams (PParamsHKD Identity ShelleyEra)

legacyFromJSONPParams :: LegacyJSONPParams -> PParams ShelleyEra
legacyFromJSONPParams :: LegacyJSONPParams -> PParams ShelleyEra
legacyFromJSONPParams (LegacyJSONPParams PParamsHKD Identity ShelleyEra
x) = forall era. PParamsHKD Identity era -> PParams era
PParams PParamsHKD Identity ShelleyEra
x

instance FromJSON LegacyJSONPParams where
  parseJSON :: Value -> Parser LegacyJSONPParams
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ShelleyPParams" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      PParamsHKD Identity ShelleyEra -> LegacyJSONPParams
LegacyJSONPParams
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (f :: * -> *) era.
HKD f Coin
-> HKD f Coin
-> HKD f Word32
-> HKD f Word32
-> HKD f Word16
-> HKD f Coin
-> HKD f Coin
-> HKD f EpochInterval
-> HKD f Word16
-> HKD f NonNegativeInterval
-> HKD f UnitInterval
-> HKD f UnitInterval
-> HKD f UnitInterval
-> HKD f Nonce
-> HKD f ProtVer
-> HKD f Coin
-> HKD f Coin
-> ShelleyPParams f era
ShelleyPParams
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"minFeeA"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"minFeeB"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"maxBlockBodySize"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"maxTxSize"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"maxBlockHeaderSize"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"keyDeposit"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"poolDeposit"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"eMax"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"nOpt"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"a0"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"rho"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tau"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"decentralisationParam"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser Nonce
parseNonce forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"extraEntropy"))
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"protocolVersion"
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"minUTxOValue" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Monoid a => a
mempty
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"minPoolCost" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Monoid a => a
mempty
            )
    where
      parseNonce :: Aeson.Value -> Parser Nonce
      parseNonce :: Value -> Parser Nonce
parseNonce =
        forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject
          String
"Nonce"
          ( \Object
obj -> do
              Text
tag <- (Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag" :: Parser Text)
              case Text
tag of
                Text
"Nonce" -> Hash Blake2b_256 Nonce -> Nonce
Nonce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
                Text
"NeutralNonce" -> forall (m :: * -> *) a. Monad m => a -> m a
return Nonce
NeutralNonce
                Text
_ -> forall a. String -> Value -> Parser a
typeMismatch String
"Nonce" (Object -> Value
Object Object
obj)
          )

legacyToJSONPParams :: PParams ShelleyEra -> LegacyJSONPParams
legacyToJSONPParams :: PParams ShelleyEra -> LegacyJSONPParams
legacyToJSONPParams (PParams PParamsHKD Identity ShelleyEra
x) = PParamsHKD Identity ShelleyEra -> LegacyJSONPParams
LegacyJSONPParams PParamsHKD Identity ShelleyEra
x

instance ToJSON LegacyJSONPParams where
  toJSON :: LegacyJSONPParams -> Value
toJSON
    ( LegacyJSONPParams
        ( ShelleyPParams
            { HKD Identity Coin
sppMinFeeA :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Coin
sppMinFeeA :: HKD Identity Coin
sppMinFeeA
            , HKD Identity Coin
sppMinFeeB :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Coin
sppMinFeeB :: HKD Identity Coin
sppMinFeeB
            , HKD Identity Word32
sppMaxBBSize :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Word32
sppMaxBBSize :: HKD Identity Word32
sppMaxBBSize
            , HKD Identity Word32
sppMaxTxSize :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Word32
sppMaxTxSize :: HKD Identity Word32
sppMaxTxSize
            , HKD Identity Word16
sppMaxBHSize :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Word16
sppMaxBHSize :: HKD Identity Word16
sppMaxBHSize
            , HKD Identity Coin
sppKeyDeposit :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Coin
sppKeyDeposit :: HKD Identity Coin
sppKeyDeposit
            , HKD Identity Coin
sppPoolDeposit :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Coin
sppPoolDeposit :: HKD Identity Coin
sppPoolDeposit
            , HKD Identity EpochInterval
sppEMax :: forall (f :: * -> *) era.
ShelleyPParams f era -> HKD f EpochInterval
sppEMax :: HKD Identity EpochInterval
sppEMax
            , HKD Identity Word16
sppNOpt :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Word16
sppNOpt :: HKD Identity Word16
sppNOpt
            , HKD Identity NonNegativeInterval
sppA0 :: forall (f :: * -> *) era.
ShelleyPParams f era -> HKD f NonNegativeInterval
sppA0 :: HKD Identity NonNegativeInterval
sppA0
            , HKD Identity UnitInterval
sppRho :: forall (f :: * -> *) era.
ShelleyPParams f era -> HKD f UnitInterval
sppRho :: HKD Identity UnitInterval
sppRho
            , HKD Identity UnitInterval
sppTau :: forall (f :: * -> *) era.
ShelleyPParams f era -> HKD f UnitInterval
sppTau :: HKD Identity UnitInterval
sppTau
            , HKD Identity UnitInterval
sppD :: forall (f :: * -> *) era.
ShelleyPParams f era -> HKD f UnitInterval
sppD :: HKD Identity UnitInterval
sppD
            , HKD Identity Nonce
sppExtraEntropy :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Nonce
sppExtraEntropy :: HKD Identity Nonce
sppExtraEntropy
            , HKD Identity ProtVer
sppProtocolVersion :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f ProtVer
sppProtocolVersion :: HKD Identity ProtVer
sppProtocolVersion
            , HKD Identity Coin
sppMinUTxOValue :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Coin
sppMinUTxOValue :: HKD Identity Coin
sppMinUTxOValue
            , HKD Identity Coin
sppMinPoolCost :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Coin
sppMinPoolCost :: HKD Identity Coin
sppMinPoolCost
            }
          )
      ) =
      [Pair] -> Value
Aeson.object
        [ Key
"minFeeA" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Coin
sppMinFeeA
        , Key
"minFeeB" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Coin
sppMinFeeB
        , Key
"maxBlockBodySize" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Word32
sppMaxBBSize
        , Key
"maxTxSize" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Word32
sppMaxTxSize
        , Key
"maxBlockHeaderSize" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Word16
sppMaxBHSize
        , Key
"keyDeposit" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Coin
sppKeyDeposit
        , Key
"poolDeposit" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Coin
sppPoolDeposit
        , Key
"eMax" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity EpochInterval
sppEMax
        , Key
"nOpt" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Word16
sppNOpt
        , Key
"a0" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity NonNegativeInterval
sppA0
        , Key
"rho" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity UnitInterval
sppRho
        , Key
"tau" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity UnitInterval
sppTau
        , Key
"decentralisationParam" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity UnitInterval
sppD
        , Key
"extraEntropy"
            forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
              ( case HKD Identity Nonce
sppExtraEntropy of
                  Nonce Hash Blake2b_256 Nonce
hash ->
                    [ Key
"tag" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"Nonce" :: Text)
                    , Key
"contents" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Hash Blake2b_256 Nonce
hash
                    ]
                  Nonce
HKD Identity Nonce
NeutralNonce -> [Key
"tag" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"NeutralNonce" :: Text)]
              )
        , Key
"protocolVersion" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity ProtVer
sppProtocolVersion
        , Key
"minUTxOValue" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Coin
sppMinUTxOValue
        , Key
"minPoolCost" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HKD Identity Coin
sppMinPoolCost
        ]

toShelleyGenesisPairs :: Aeson.KeyValue e a => ShelleyGenesis -> [a]
toShelleyGenesisPairs :: forall e a. KeyValue e a => ShelleyGenesis -> [a]
toShelleyGenesisPairs
  ShelleyGenesis
    { UTCTime
sgSystemStart :: UTCTime
sgSystemStart :: ShelleyGenesis -> UTCTime
sgSystemStart
    , Word32
sgNetworkMagic :: Word32
sgNetworkMagic :: ShelleyGenesis -> Word32
sgNetworkMagic
    , Network
sgNetworkId :: Network
sgNetworkId :: ShelleyGenesis -> Network
sgNetworkId
    , PositiveUnitInterval
sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff :: ShelleyGenesis -> PositiveUnitInterval
sgActiveSlotsCoeff
    , NonZero Word64
sgSecurityParam :: NonZero Word64
sgSecurityParam :: ShelleyGenesis -> NonZero Word64
sgSecurityParam
    , EpochSize
sgEpochLength :: EpochSize
sgEpochLength :: ShelleyGenesis -> EpochSize
sgEpochLength
    , Word64
sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod :: ShelleyGenesis -> Word64
sgSlotsPerKESPeriod
    , Word64
sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions :: ShelleyGenesis -> Word64
sgMaxKESEvolutions
    , NominalDiffTimeMicro
sgSlotLength :: NominalDiffTimeMicro
sgSlotLength :: ShelleyGenesis -> NominalDiffTimeMicro
sgSlotLength
    , Word64
sgUpdateQuorum :: Word64
sgUpdateQuorum :: ShelleyGenesis -> Word64
sgUpdateQuorum
    , Word64
sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply :: ShelleyGenesis -> Word64
sgMaxLovelaceSupply
    , PParams ShelleyEra
sgProtocolParams :: PParams ShelleyEra
sgProtocolParams :: ShelleyGenesis -> PParams ShelleyEra
sgProtocolParams
    , Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs :: Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs :: ShelleyGenesis -> Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs
    , ListMap Addr Coin
sgInitialFunds :: ListMap Addr Coin
sgInitialFunds :: ShelleyGenesis -> ListMap Addr Coin
sgInitialFunds
    , ShelleyGenesisStaking
sgStaking :: ShelleyGenesisStaking
sgStaking :: ShelleyGenesis -> ShelleyGenesisStaking
sgStaking
    } =
    let !strictSgInitialFunds :: ListMap Addr Coin
strictSgInitialFunds = ListMap Addr Coin
sgInitialFunds
        !strictSgStaking :: ShelleyGenesisStaking
strictSgStaking = ShelleyGenesisStaking
sgStaking
     in [ Key
"systemStart" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
sgSystemStart
        , Key
"networkMagic" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word32
sgNetworkMagic
        , Key
"networkId" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Network
sgNetworkId
        , Key
"activeSlotsCoeff" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PositiveUnitInterval
sgActiveSlotsCoeff
        , Key
"securityParam" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NonZero Word64
sgSecurityParam
        , Key
"epochLength" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= EpochSize
sgEpochLength
        , Key
"slotsPerKESPeriod" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
sgSlotsPerKESPeriod
        , Key
"maxKESEvolutions" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
sgMaxKESEvolutions
        , Key
"slotLength" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NominalDiffTimeMicro
sgSlotLength
        , Key
"updateQuorum" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
sgUpdateQuorum
        , Key
"maxLovelaceSupply" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
sgMaxLovelaceSupply
        , Key
"protocolParams" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PParams ShelleyEra -> LegacyJSONPParams
legacyToJSONPParams PParams ShelleyEra
sgProtocolParams
        , Key
"genDelegs" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs
        , Key
"initialFunds" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ListMap Addr Coin
strictSgInitialFunds
        , Key
"staking" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ShelleyGenesisStaking
strictSgStaking
        ]

instance FromJSON ShelleyGenesis where
  parseJSON :: Value -> Parser ShelleyGenesis
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ShelleyGenesis" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      UTCTime
-> Word32
-> Network
-> PositiveUnitInterval
-> NonZero Word64
-> EpochSize
-> Word64
-> Word64
-> NominalDiffTimeMicro
-> Word64
-> Word64
-> PParams ShelleyEra
-> Map (KeyHash 'Genesis) GenDelegPair
-> ListMap Addr Coin
-> ShelleyGenesisStaking
-> ShelleyGenesis
ShelleyGenesis
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UTCTime -> UTCTime
forceUTCTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"systemStart")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"networkMagic"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"networkId"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"activeSlotsCoeff"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"securityParam"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"epochLength"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"slotsPerKESPeriod"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"maxKESEvolutions"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"slotLength"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"updateQuorum"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"maxLovelaceSupply"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LegacyJSONPParams -> PParams ShelleyEra
legacyFromJSONPParams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"protocolParams")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"genDelegs")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"initialFunds") -- TODO: disable. Move to EraTransition
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"staking" forall a. Parser (Maybe a) -> a -> Parser a
.!= ShelleyGenesisStaking
emptyGenesisStaking -- TODO: remove. Move to EraTransition
    where
      forceUTCTime :: UTCTime -> UTCTime
forceUTCTime UTCTime
date =
        let !day :: Day
day = UTCTime -> Day
utctDay UTCTime
date
            !time :: DiffTime
time = UTCTime -> DiffTime
utctDayTime UTCTime
date
         in Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
time

instance ToJSON ShelleyGenesisStaking where
  toJSON :: ShelleyGenesisStaking -> Value
toJSON = [Pair] -> Value
Aeson.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => ShelleyGenesisStaking -> [a]
toShelleyGenesisStakingPairs
  toEncoding :: ShelleyGenesisStaking -> Encoding
toEncoding = Series -> Encoding
Aeson.pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => ShelleyGenesisStaking -> [a]
toShelleyGenesisStakingPairs

toShelleyGenesisStakingPairs ::
  Aeson.KeyValue e a =>
  ShelleyGenesisStaking ->
  [a]
toShelleyGenesisStakingPairs :: forall e a. KeyValue e a => ShelleyGenesisStaking -> [a]
toShelleyGenesisStakingPairs ShelleyGenesisStaking {ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ShelleyGenesisStaking -> ListMap (KeyHash 'StakePool) PoolParams
sgsPools, ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ShelleyGenesisStaking
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake} =
  [ Key
"pools" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ListMap (KeyHash 'StakePool) PoolParams
sgsPools
  , Key
"stake" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake
  ]

instance FromJSON ShelleyGenesisStaking where
  parseJSON :: Value -> Parser ShelleyGenesisStaking
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ShelleyGenesisStaking" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      ListMap (KeyHash 'StakePool) PoolParams
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
-> ShelleyGenesisStaking
ShelleyGenesisStaking
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pools")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"stake")

-- | Genesis are always encoded with the version of era they are defined in.
instance DecCBOR ShelleyGenesis

instance EncCBOR ShelleyGenesis

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

instance FromCBOR ShelleyGenesis where
  fromCBOR :: forall s. Decoder s ShelleyGenesis
fromCBOR = forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder forall a. Maybe a
Nothing Version
shelleyProtVer forall a b. (a -> b) -> a -> b
$ do
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"ShelleyGenesis" (forall a b. a -> b -> a
const Int
15) forall a b. (a -> b) -> a -> b
$ do
      UTCTime
sgSystemStart <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Word32
sgNetworkMagic <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Network
sgNetworkId <- forall a s. DecCBOR a => Decoder s a
decCBOR
      PositiveUnitInterval
sgActiveSlotsCoeff <- forall s. Decoder s PositiveUnitInterval
activeSlotsCoeffDecCBOR
      NonZero Word64
sgSecurityParam <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Word64
sgEpochLength <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Word64
sgSlotsPerKESPeriod <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Word64
sgMaxKESEvolutions <- forall a s. DecCBOR a => Decoder s a
decCBOR
      NominalDiffTimeMicro
sgSlotLength <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Word64
sgUpdateQuorum <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Word64
sgMaxLovelaceSupply <- forall a s. DecCBOR a => Decoder s a
decCBOR
      PParams ShelleyEra
sgProtocolParams <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs <- forall a s. DecCBOR a => Decoder s a
decCBOR
      ListMap Addr Coin
sgInitialFunds <- forall a s. DecCBOR a => Decoder s a
decCBOR
      ShelleyGenesisStaking
sgStaking <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        UTCTime
-> Word32
-> Network
-> PositiveUnitInterval
-> NonZero Word64
-> EpochSize
-> Word64
-> Word64
-> NominalDiffTimeMicro
-> Word64
-> Word64
-> PParams ShelleyEra
-> Map (KeyHash 'Genesis) GenDelegPair
-> ListMap Addr Coin
-> ShelleyGenesisStaking
-> ShelleyGenesis
ShelleyGenesis
          UTCTime
sgSystemStart
          Word32
sgNetworkMagic
          Network
sgNetworkId
          PositiveUnitInterval
sgActiveSlotsCoeff
          NonZero Word64
sgSecurityParam
          (Word64 -> EpochSize
EpochSize Word64
sgEpochLength)
          Word64
sgSlotsPerKESPeriod
          Word64
sgMaxKESEvolutions
          NominalDiffTimeMicro
sgSlotLength
          Word64
sgUpdateQuorum
          Word64
sgMaxLovelaceSupply
          PParams ShelleyEra
sgProtocolParams
          Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs
          ListMap Addr Coin
sgInitialFunds
          ShelleyGenesisStaking
sgStaking

-- | Serialize `PositiveUnitInterval` type in the same way `Rational` is serialized,
-- however ensure there is no usage of tag 30 by enforcing Shelley protocol version.
activeSlotsCoeffEncCBOR :: PositiveUnitInterval -> Encoding
activeSlotsCoeffEncCBOR :: PositiveUnitInterval -> Encoding
activeSlotsCoeffEncCBOR = Version -> Encoding -> Encoding
enforceEncodingVersion Version
shelleyProtVer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBOR a => a -> Encoding
encCBOR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. BoundedRational r => r -> Rational
unboundRational

-- | Deserialize `PositiveUnitInterval` type using `Rational` deserialization and fail
-- when bounds are violated. Also, ensure there is no usage of tag 30 by enforcing Shelley
-- protocol version.
activeSlotsCoeffDecCBOR :: Decoder s PositiveUnitInterval
activeSlotsCoeffDecCBOR :: forall s. Decoder s PositiveUnitInterval
activeSlotsCoeffDecCBOR = do
  Rational
r <- forall s a. Version -> Decoder s a -> Decoder s a
enforceDecoderVersion Version
shelleyProtVer forall a b. (a -> b) -> a -> b
$ forall s. Decoder s Rational
decodeRational
  case forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
r of
    Maybe PositiveUnitInterval
Nothing ->
      forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"ActiveSlotsCoeff (PositiveUnitInterval)" (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Rational
r)
    Just PositiveUnitInterval
u -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PositiveUnitInterval
u

{-------------------------------------------------------------------------------
  Genesis UTxO
-------------------------------------------------------------------------------}

genesisUTxO ::
  forall era.
  EraTxOut era =>
  ShelleyGenesis ->
  UTxO era
genesisUTxO :: forall era. EraTxOut era => ShelleyGenesis -> UTxO era
genesisUTxO ShelleyGenesis
genesis =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxIn
txIn, TxOut era
txOut)
      | (Addr
addr, Coin
amount) <- forall k v. ListMap k v -> [(k, v)]
LM.unListMap (ShelleyGenesis -> ListMap Addr Coin
sgInitialFunds ShelleyGenesis
genesis)
      , let txIn :: TxIn
txIn = Addr -> TxIn
initialFundsPseudoTxIn Addr
addr
            txOut :: TxOut era
txOut = forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (forall t s. Inject t s => t -> s
Val.inject Coin
amount)
      ]

-- | Compute the 'TxIn' of the initial UTxO pseudo-transaction corresponding
-- to the given address in the genesis initial funds.
--
-- The Shelley initial UTxO is constructed from the 'sgInitialFunds' which
-- is not a full UTxO but just a map from addresses to coin values.
--
-- This gets turned into a UTxO by making a pseudo-transaction for each address,
-- with the 0th output being the coin value. So to spend from the initial UTxO
-- we need this same 'TxIn' to use as an input to the spending transaction.
initialFundsPseudoTxIn :: Addr -> TxIn
initialFundsPseudoTxIn :: Addr -> TxIn
initialFundsPseudoTxIn Addr
addr =
  TxId -> TxIx -> TxIn
TxIn (Addr -> TxId
pseudoTxId Addr
addr) forall a. Bounded a => a
minBound
  where
    pseudoTxId :: Addr -> TxId
pseudoTxId =
      SafeHash EraIndependentTxBody -> TxId
TxId
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Hash Blake2b_256 i -> SafeHash i
unsafeMakeSafeHash
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( forall h a b. Hash h a -> Hash h b
H.castHash ::
              H.Hash HASH Addr ->
              H.Hash HASH EraIndependentTxBody
          )
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
H.hashWith Addr -> ByteString
serialiseAddr

{-------------------------------------------------------------------------------
  Genesis validation
-------------------------------------------------------------------------------}

data ValidationErr
  = EpochNotLongEnough EpochSize Word64 Rational EpochSize
  | MaxKESEvolutionsUnsupported Word64 Word
  | QuorumTooSmall Word64 Word64 Word64
  deriving (ValidationErr -> ValidationErr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationErr -> ValidationErr -> Bool
$c/= :: ValidationErr -> ValidationErr -> Bool
== :: ValidationErr -> ValidationErr -> Bool
$c== :: ValidationErr -> ValidationErr -> Bool
Eq, Int -> ValidationErr -> ShowS
[ValidationErr] -> ShowS
ValidationErr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationErr] -> ShowS
$cshowList :: [ValidationErr] -> ShowS
show :: ValidationErr -> String
$cshow :: ValidationErr -> String
showsPrec :: Int -> ValidationErr -> ShowS
$cshowsPrec :: Int -> ValidationErr -> ShowS
Show)

describeValidationErr :: ValidationErr -> Text
describeValidationErr :: ValidationErr -> Text
describeValidationErr (EpochNotLongEnough EpochSize
es Word64
secParam Rational
asc EpochSize
minEpochSize) =
  forall a. Monoid a => [a] -> a
mconcat
    [ Text
"Epoch length is too low. Your epoch length of "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show EpochSize
es)
    , Text
" does not meet the minimum epoch length of "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show EpochSize
minEpochSize)
    , Text
" required by your choice of parameters for k and f: "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show Word64
secParam)
    , Text
" and "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show Rational
asc)
    , Text
". Epochs should be at least 10k/f slots long."
    ]
describeValidationErr (MaxKESEvolutionsUnsupported Word64
reqKES Word
supportedKES) =
  forall a. Monoid a => [a] -> a
mconcat
    [ Text
"You have specified a 'maxKESEvolutions' higher"
    , Text
" than that supported by the underlying algorithm."
    , Text
" You requested "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show Word64
reqKES)
    , Text
" but the algorithm supports a maximum of "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show Word
supportedKES)
    ]
describeValidationErr (QuorumTooSmall Word64
q Word64
maxTooSmal Word64
nodes) =
  forall a. Monoid a => [a] -> a
mconcat
    [ Text
"You have specified an 'updateQuorum' which is"
    , Text
" too small compared to the number of genesis nodes."
    , Text
" You requested "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show Word64
q)
    , Text
", but given "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show Word64
nodes)
    , Text
" genesis nodes 'updateQuorum' must be greater than "
    , String -> Text
Text.pack (forall a. Show a => a -> String
show Word64
maxTooSmal)
    ]

-- | Do some basic sanity checking on the Shelley genesis file.
validateGenesis :: ShelleyGenesis -> Either [ValidationErr] ()
validateGenesis :: ShelleyGenesis -> Either [ValidationErr] ()
validateGenesis
  ShelleyGenesis
    { EpochSize
sgEpochLength :: EpochSize
sgEpochLength :: ShelleyGenesis -> EpochSize
sgEpochLength
    , PositiveUnitInterval
sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff :: ShelleyGenesis -> PositiveUnitInterval
sgActiveSlotsCoeff
    , Word64
sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions :: ShelleyGenesis -> Word64
sgMaxKESEvolutions
    , NonZero Word64
sgSecurityParam :: NonZero Word64
sgSecurityParam :: ShelleyGenesis -> NonZero Word64
sgSecurityParam
    , Word64
sgUpdateQuorum :: Word64
sgUpdateQuorum :: ShelleyGenesis -> Word64
sgUpdateQuorum
    , Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs :: Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs :: ShelleyGenesis -> Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs
    } =
    case forall a. [Maybe a] -> [a]
catMaybes [Maybe ValidationErr]
errors of
      [] -> forall a b. b -> Either a b
Right ()
      [ValidationErr]
xs -> forall a b. a -> Either a b
Left [ValidationErr]
xs
    where
      errors :: [Maybe ValidationErr]
errors =
        [ Maybe ValidationErr
checkEpochLength
        , Maybe ValidationErr
checkKesEvolutions
        , Maybe ValidationErr
checkQuorumSize
        ]
      checkEpochLength :: Maybe ValidationErr
checkEpochLength =
        let activeSlotsCoeff :: Rational
activeSlotsCoeff = forall r. BoundedRational r => r -> Rational
unboundRational PositiveUnitInterval
sgActiveSlotsCoeff
            minLength :: EpochSize
minLength =
              Word64 -> EpochSize
EpochSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$
                forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Double (Word64
3 forall a. Num a => a -> a -> a
* forall a. NonZero a -> a
unNonZero NonZero Word64
sgSecurityParam)
                  forall a. Fractional a => a -> a -> a
/ forall a. Fractional a => Rational -> a
fromRational Rational
activeSlotsCoeff
         in if EpochSize
minLength forall a. Ord a => a -> a -> Bool
> EpochSize
sgEpochLength
              then
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                  EpochSize -> Word64 -> Rational -> EpochSize -> ValidationErr
EpochNotLongEnough
                    EpochSize
sgEpochLength
                    (forall a. NonZero a -> a
unNonZero NonZero Word64
sgSecurityParam)
                    Rational
activeSlotsCoeff
                    EpochSize
minLength
              else forall a. Maybe a
Nothing
      kesPeriods :: Word
kesPeriods = forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy @(Sum6KES Ed25519DSIGN Blake2b_256))
      checkKesEvolutions :: Maybe ValidationErr
checkKesEvolutions =
        if Word64
sgMaxKESEvolutions forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
kesPeriods
          then forall a. Maybe a
Nothing
          else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word64 -> Word -> ValidationErr
MaxKESEvolutionsUnsupported Word64
sgMaxKESEvolutions Word
kesPeriods
      checkQuorumSize :: Maybe ValidationErr
checkQuorumSize =
        let numGenesisNodes :: Word64
numGenesisNodes = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs
            maxTooSmal :: Word64
maxTooSmal = Word64
numGenesisNodes forall a. Integral a => a -> a -> a
`div` Word64
2
         in if Word64
numGenesisNodes forall a. Eq a => a -> a -> Bool
== Word64
0 Bool -> Bool -> Bool
|| Word64
sgUpdateQuorum forall a. Ord a => a -> a -> Bool
> Word64
maxTooSmal
              then forall a. Maybe a
Nothing
              else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> ValidationErr
QuorumTooSmall Word64
sgUpdateQuorum Word64
maxTooSmal Word64
numGenesisNodes

{-------------------------------------------------------------------------------
  Construct 'Globals' using 'ShelleyGenesis'
-------------------------------------------------------------------------------}

mkShelleyGlobals :: ShelleyGenesis -> EpochInfo (Either Text) -> Globals
mkShelleyGlobals :: ShelleyGenesis -> EpochInfo (Either Text) -> Globals
mkShelleyGlobals ShelleyGenesis
genesis EpochInfo (Either Text)
epochInfoAc =
  Globals
    { activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff = ShelleyGenesis -> ActiveSlotCoeff
sgActiveSlotCoeff ShelleyGenesis
genesis
    , epochInfo :: EpochInfo (Either Text)
epochInfo = EpochInfo (Either Text)
epochInfoAc
    , maxKESEvo :: Word64
maxKESEvo = ShelleyGenesis -> Word64
sgMaxKESEvolutions ShelleyGenesis
genesis
    , maxLovelaceSupply :: Word64
maxLovelaceSupply = ShelleyGenesis -> Word64
sgMaxLovelaceSupply ShelleyGenesis
genesis
    , networkId :: Network
networkId = ShelleyGenesis -> Network
sgNetworkId ShelleyGenesis
genesis
    , quorum :: Word64
quorum = ShelleyGenesis -> Word64
sgUpdateQuorum ShelleyGenesis
genesis
    , Word64
randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow
    , securityParameter :: NonZero Word64
securityParameter = NonZero Word64
k
    , slotsPerKESPeriod :: Word64
slotsPerKESPeriod = ShelleyGenesis -> Word64
sgSlotsPerKESPeriod ShelleyGenesis
genesis
    , Word64
stabilityWindow :: Word64
stabilityWindow :: Word64
stabilityWindow
    , SystemStart
systemStart :: SystemStart
systemStart :: SystemStart
systemStart
    }
  where
    systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> UTCTime
sgSystemStart ShelleyGenesis
genesis
    k :: NonZero Word64
k = ShelleyGenesis -> NonZero Word64
sgSecurityParam ShelleyGenesis
genesis
    stabilityWindow :: Word64
stabilityWindow =
      Word64 -> ActiveSlotCoeff -> Word64
computeStabilityWindow (forall a. NonZero a -> a
unNonZero NonZero Word64
k) (ShelleyGenesis -> ActiveSlotCoeff
sgActiveSlotCoeff ShelleyGenesis
genesis)
    randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow =
      Word64 -> ActiveSlotCoeff -> Word64
computeRandomnessStabilisationWindow (forall a. NonZero a -> a
unNonZero NonZero Word64
k) (ShelleyGenesis -> ActiveSlotCoeff
sgActiveSlotCoeff ShelleyGenesis
genesis)