{-# 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 qualified Cardano.Crypto.Hash.Class as Crypto
import Cardano.Crypto.KES.Class (totalPeriodsKES)
import Cardano.Ledger.Address (Addr, serialiseAddr)
import Cardano.Ledger.BaseTypes (
  ActiveSlotCoeff,
  BoundedRational (boundRational, unboundRational),
  EpochSize (..),
  Globals (..),
  Network,
  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.Crypto (Crypto, HASH, KES)
import Cardano.Ledger.Genesis (EraGenesis (..))
import Cardano.Ledger.Keys
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.SafeHash (unsafeMakeSafeHash)
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams (ShelleyPParams (..))
import Cardano.Ledger.Shelley.StabilityWindow
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.UTxO (UTxO (UTxO))
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 c = ShelleyGenesisStaking
  { forall c.
ShelleyGenesisStaking c
-> ListMap (KeyHash 'StakePool c) (PoolParams c)
sgsPools :: LM.ListMap (KeyHash 'StakePool c) (PoolParams c)
  -- ^ 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'.
  , forall c.
ShelleyGenesisStaking c
-> ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
sgsStake :: LM.ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
  -- ^ 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 c -> ShelleyGenesisStaking c -> Bool
forall c.
ShelleyGenesisStaking c -> ShelleyGenesisStaking c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleyGenesisStaking c -> ShelleyGenesisStaking c -> Bool
$c/= :: forall c.
ShelleyGenesisStaking c -> ShelleyGenesisStaking c -> Bool
== :: ShelleyGenesisStaking c -> ShelleyGenesisStaking c -> Bool
$c== :: forall c.
ShelleyGenesisStaking c -> ShelleyGenesisStaking c -> Bool
Eq, Int -> ShelleyGenesisStaking c -> ShowS
forall c. Int -> ShelleyGenesisStaking c -> ShowS
forall c. [ShelleyGenesisStaking c] -> ShowS
forall c. ShelleyGenesisStaking c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyGenesisStaking c] -> ShowS
$cshowList :: forall c. [ShelleyGenesisStaking c] -> ShowS
show :: ShelleyGenesisStaking c -> String
$cshow :: forall c. ShelleyGenesisStaking c -> String
showsPrec :: Int -> ShelleyGenesisStaking c -> ShowS
$cshowsPrec :: forall c. Int -> ShelleyGenesisStaking c -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (ShelleyGenesisStaking c) x -> ShelleyGenesisStaking c
forall c x.
ShelleyGenesisStaking c -> Rep (ShelleyGenesisStaking c) x
$cto :: forall c x.
Rep (ShelleyGenesisStaking c) x -> ShelleyGenesisStaking c
$cfrom :: forall c x.
ShelleyGenesisStaking c -> Rep (ShelleyGenesisStaking c) x
Generic)

instance NoThunks (ShelleyGenesisStaking c)

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

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

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

instance Crypto c => DecCBOR (ShelleyGenesisStaking c) where
  decCBOR :: forall s. Decoder s (ShelleyGenesisStaking c)
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 c) (PoolParams c)
pools <- forall a s. DecCBOR a => Decoder s a
decCBOR
      ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
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
$ forall c.
ListMap (KeyHash 'StakePool c) (PoolParams c)
-> ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
-> ShelleyGenesisStaking c
ShelleyGenesisStaking ListMap (KeyHash 'StakePool c) (PoolParams c)
pools ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
stake

-- | Empty genesis staking
emptyGenesisStaking :: ShelleyGenesisStaking c
emptyGenesisStaking :: forall c. ShelleyGenesisStaking c
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 c = ShelleyGenesis
  { forall c. ShelleyGenesis c -> UTCTime
sgSystemStart :: !UTCTime
  , forall c. ShelleyGenesis c -> Word32
sgNetworkMagic :: !Word32
  , forall c. ShelleyGenesis c -> Network
sgNetworkId :: !Network
  , forall c. ShelleyGenesis c -> PositiveUnitInterval
sgActiveSlotsCoeff :: !PositiveUnitInterval
  , forall c. ShelleyGenesis c -> Word64
sgSecurityParam :: !Word64
  , forall c. ShelleyGenesis c -> EpochSize
sgEpochLength :: !EpochSize
  , forall c. ShelleyGenesis c -> Word64
sgSlotsPerKESPeriod :: !Word64
  , forall c. ShelleyGenesis c -> Word64
sgMaxKESEvolutions :: !Word64
  , forall c. ShelleyGenesis c -> NominalDiffTimeMicro
sgSlotLength :: !NominalDiffTimeMicro
  , forall c. ShelleyGenesis c -> Word64
sgUpdateQuorum :: !Word64
  , forall c. ShelleyGenesis c -> Word64
sgMaxLovelaceSupply :: !Word64
  , forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams :: !(PParams (ShelleyEra c))
  , forall c.
ShelleyGenesis c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs :: !(Map (KeyHash 'Genesis c) (GenDelegPair c))
  , forall c. ShelleyGenesis c -> ListMap (Addr c) Coin
sgInitialFunds :: LM.ListMap (Addr c) Coin
  -- ^ 'sgInitialFunds' is intentionally kept lazy, as it can otherwise cause
  --   out-of-memory problems in testing and benchmarking.
  , forall c. ShelleyGenesis c -> ShelleyGenesisStaking c
sgStaking :: ShelleyGenesisStaking c
  -- ^ 'sgStaking' is intentionally kept lazy, as it can otherwise cause
  --   out-of-memory problems in testing and benchmarking.
  }
  deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (ShelleyGenesis c) x -> ShelleyGenesis c
forall c x. ShelleyGenesis c -> Rep (ShelleyGenesis c) x
$cto :: forall c x. Rep (ShelleyGenesis c) x -> ShelleyGenesis c
$cfrom :: forall c x. ShelleyGenesis c -> Rep (ShelleyGenesis c) x
Generic)

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

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

deriving instance Crypto c => Show (ShelleyGenesis c)

deriving instance Crypto c => Eq (ShelleyGenesis c)

deriving via
  AllowThunksIn '["sgInitialFunds", "sgStaking"] (ShelleyGenesis c)
  instance
    Crypto c => NoThunks (ShelleyGenesis c)

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

instance Crypto c => ToJSON (ShelleyGenesis c) where
  toJSON :: ShelleyGenesis c -> Value
toJSON = [Pair] -> Value
Aeson.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c. (KeyValue e a, Crypto c) => ShelleyGenesis c -> [a]
toShelleyGenesisPairs
  toEncoding :: ShelleyGenesis c -> 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 c. (KeyValue e a, Crypto c) => ShelleyGenesis c -> [a]
toShelleyGenesisPairs

instance Crypto c => EraGenesis (ShelleyEra c) where
  type Genesis (ShelleyEra c) = ShelleyGenesis c

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

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

instance FromJSON (LegacyJSONPParams c) where
  parseJSON :: Value -> Parser (LegacyJSONPParams c)
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ShelleyPParams" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      forall c. PParamsHKD Identity (ShelleyEra c) -> LegacyJSONPParams c
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 Natural
-> 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 c) -> LegacyJSONPParams c
legacyToJSONPParams :: forall c. PParams (ShelleyEra c) -> LegacyJSONPParams c
legacyToJSONPParams (PParams PParamsHKD Identity (ShelleyEra c)
x) = forall c. PParamsHKD Identity (ShelleyEra c) -> LegacyJSONPParams c
LegacyJSONPParams PParamsHKD Identity (ShelleyEra c)
x

instance ToJSON (LegacyJSONPParams c) where
  toJSON :: LegacyJSONPParams c -> 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 Natural
sppNOpt :: forall (f :: * -> *) era. ShelleyPParams f era -> HKD f Natural
sppNOpt :: HKD Identity Natural
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 Natural
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, Crypto c) => ShelleyGenesis c -> [a]
toShelleyGenesisPairs :: forall e a c. (KeyValue e a, Crypto c) => ShelleyGenesis c -> [a]
toShelleyGenesisPairs
  ShelleyGenesis
    { UTCTime
sgSystemStart :: UTCTime
sgSystemStart :: forall c. ShelleyGenesis c -> UTCTime
sgSystemStart
    , Word32
sgNetworkMagic :: Word32
sgNetworkMagic :: forall c. ShelleyGenesis c -> Word32
sgNetworkMagic
    , Network
sgNetworkId :: Network
sgNetworkId :: forall c. ShelleyGenesis c -> Network
sgNetworkId
    , PositiveUnitInterval
sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff :: forall c. ShelleyGenesis c -> PositiveUnitInterval
sgActiveSlotsCoeff
    , Word64
sgSecurityParam :: Word64
sgSecurityParam :: forall c. ShelleyGenesis c -> Word64
sgSecurityParam
    , EpochSize
sgEpochLength :: EpochSize
sgEpochLength :: forall c. ShelleyGenesis c -> EpochSize
sgEpochLength
    , Word64
sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod :: forall c. ShelleyGenesis c -> Word64
sgSlotsPerKESPeriod
    , Word64
sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions :: forall c. ShelleyGenesis c -> Word64
sgMaxKESEvolutions
    , NominalDiffTimeMicro
sgSlotLength :: NominalDiffTimeMicro
sgSlotLength :: forall c. ShelleyGenesis c -> NominalDiffTimeMicro
sgSlotLength
    , Word64
sgUpdateQuorum :: Word64
sgUpdateQuorum :: forall c. ShelleyGenesis c -> Word64
sgUpdateQuorum
    , Word64
sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply :: forall c. ShelleyGenesis c -> Word64
sgMaxLovelaceSupply
    , PParams (ShelleyEra c)
sgProtocolParams :: PParams (ShelleyEra c)
sgProtocolParams :: forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams
    , Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs :: forall c.
ShelleyGenesis c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs
    , ListMap (Addr c) Coin
sgInitialFunds :: ListMap (Addr c) Coin
sgInitialFunds :: forall c. ShelleyGenesis c -> ListMap (Addr c) Coin
sgInitialFunds
    , ShelleyGenesisStaking c
sgStaking :: ShelleyGenesisStaking c
sgStaking :: forall c. ShelleyGenesis c -> ShelleyGenesisStaking c
sgStaking
    } =
    let !strictSgInitialFunds :: ListMap (Addr c) Coin
strictSgInitialFunds = ListMap (Addr c) Coin
sgInitialFunds
        !strictSgStaking :: ShelleyGenesisStaking c
strictSgStaking = ShelleyGenesisStaking c
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
.= 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
.= forall c. PParams (ShelleyEra c) -> LegacyJSONPParams c
legacyToJSONPParams PParams (ShelleyEra c)
sgProtocolParams
        , Key
"genDelegs" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs
        , Key
"initialFunds" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ListMap (Addr c) Coin
strictSgInitialFunds
        , Key
"staking" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ShelleyGenesisStaking c
strictSgStaking
        ]

instance Crypto c => FromJSON (ShelleyGenesis c) where
  parseJSON :: Value -> Parser (ShelleyGenesis c)
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ShelleyGenesis" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      forall c.
UTCTime
-> Word32
-> Network
-> PositiveUnitInterval
-> Word64
-> EpochSize
-> Word64
-> Word64
-> NominalDiffTimeMicro
-> Word64
-> Word64
-> PParams (ShelleyEra c)
-> Map (KeyHash 'Genesis c) (GenDelegPair c)
-> ListMap (Addr c) Coin
-> ShelleyGenesisStaking c
-> ShelleyGenesis c
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
<*> (forall c. LegacyJSONPParams c -> PParams (ShelleyEra c)
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
.!= forall c. ShelleyGenesisStaking c
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 Crypto c => ToJSON (ShelleyGenesisStaking c) where
  toJSON :: ShelleyGenesisStaking c -> Value
toJSON = [Pair] -> Value
Aeson.object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c.
(KeyValue e a, Crypto c) =>
ShelleyGenesisStaking c -> [a]
toShelleyGenesisStakingPairs
  toEncoding :: ShelleyGenesisStaking c -> 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 c.
(KeyValue e a, Crypto c) =>
ShelleyGenesisStaking c -> [a]
toShelleyGenesisStakingPairs

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

instance Crypto c => FromJSON (ShelleyGenesisStaking c) where
  parseJSON :: Value -> Parser (ShelleyGenesisStaking c)
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ShelleyGenesisStaking" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      forall c.
ListMap (KeyHash 'StakePool c) (PoolParams c)
-> ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
-> ShelleyGenesisStaking c
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 Crypto c => DecCBOR (ShelleyGenesis c)

instance Crypto c => EncCBOR (ShelleyGenesis c)

instance Crypto c => ToCBOR (ShelleyGenesis c) where
  toCBOR :: ShelleyGenesis c -> Encoding
toCBOR
    ShelleyGenesis
      { UTCTime
sgSystemStart :: UTCTime
sgSystemStart :: forall c. ShelleyGenesis c -> UTCTime
sgSystemStart
      , Word32
sgNetworkMagic :: Word32
sgNetworkMagic :: forall c. ShelleyGenesis c -> Word32
sgNetworkMagic
      , Network
sgNetworkId :: Network
sgNetworkId :: forall c. ShelleyGenesis c -> Network
sgNetworkId
      , PositiveUnitInterval
sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff :: forall c. ShelleyGenesis c -> PositiveUnitInterval
sgActiveSlotsCoeff
      , Word64
sgSecurityParam :: Word64
sgSecurityParam :: forall c. ShelleyGenesis c -> Word64
sgSecurityParam
      , EpochSize
sgEpochLength :: EpochSize
sgEpochLength :: forall c. ShelleyGenesis c -> EpochSize
sgEpochLength
      , Word64
sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod :: forall c. ShelleyGenesis c -> Word64
sgSlotsPerKESPeriod
      , Word64
sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions :: forall c. ShelleyGenesis c -> Word64
sgMaxKESEvolutions
      , NominalDiffTimeMicro
sgSlotLength :: NominalDiffTimeMicro
sgSlotLength :: forall c. ShelleyGenesis c -> NominalDiffTimeMicro
sgSlotLength
      , Word64
sgUpdateQuorum :: Word64
sgUpdateQuorum :: forall c. ShelleyGenesis c -> Word64
sgUpdateQuorum
      , Word64
sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply :: forall c. ShelleyGenesis c -> Word64
sgMaxLovelaceSupply
      , PParams (ShelleyEra c)
sgProtocolParams :: PParams (ShelleyEra c)
sgProtocolParams :: forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams
      , Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs :: forall c.
ShelleyGenesis c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs
      , ListMap (Addr c) Coin
sgInitialFunds :: ListMap (Addr c) Coin
sgInitialFunds :: forall c. ShelleyGenesis c -> ListMap (Addr c) Coin
sgInitialFunds
      , ShelleyGenesisStaking c
sgStaking :: ShelleyGenesisStaking c
sgStaking :: forall c. ShelleyGenesis c -> ShelleyGenesisStaking c
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 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 c)
sgProtocolParams
          forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs
          forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ListMap (Addr c) Coin
sgInitialFunds
          forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ShelleyGenesisStaking c
sgStaking

instance Crypto c => FromCBOR (ShelleyGenesis c) where
  fromCBOR :: forall s. Decoder s (ShelleyGenesis c)
fromCBOR = forall s a. Version -> Decoder s a -> Decoder s a
toPlainDecoder 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
      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 c)
sgProtocolParams <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs <- forall a s. DecCBOR a => Decoder s a
decCBOR
      ListMap (Addr c) Coin
sgInitialFunds <- forall a s. DecCBOR a => Decoder s a
decCBOR
      ShelleyGenesisStaking c
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
$
        forall c.
UTCTime
-> Word32
-> Network
-> PositiveUnitInterval
-> Word64
-> EpochSize
-> Word64
-> Word64
-> NominalDiffTimeMicro
-> Word64
-> Word64
-> PParams (ShelleyEra c)
-> Map (KeyHash 'Genesis c) (GenDelegPair c)
-> ListMap (Addr c) Coin
-> ShelleyGenesisStaking c
-> ShelleyGenesis c
ShelleyGenesis
          UTCTime
sgSystemStart
          Word32
sgNetworkMagic
          Network
sgNetworkId
          PositiveUnitInterval
sgActiveSlotsCoeff
          Word64
sgSecurityParam
          (Word64 -> EpochSize
EpochSize Word64
sgEpochLength)
          Word64
sgSlotsPerKESPeriod
          Word64
sgMaxKESEvolutions
          NominalDiffTimeMicro
sgSlotLength
          Word64
sgUpdateQuorum
          Word64
sgMaxLovelaceSupply
          PParams (ShelleyEra c)
sgProtocolParams
          Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs
          ListMap (Addr c) Coin
sgInitialFunds
          ShelleyGenesisStaking c
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 (EraCrypto era) ->
  UTxO era
genesisUTxO :: forall era.
EraTxOut era =>
ShelleyGenesis (EraCrypto era) -> UTxO era
genesisUTxO ShelleyGenesis (EraCrypto era)
genesis =
  forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era)
txIn, TxOut era
txOut)
      | (Addr (EraCrypto era)
addr, Coin
amount) <- forall k v. ListMap k v -> [(k, v)]
LM.unListMap (forall c. ShelleyGenesis c -> ListMap (Addr c) Coin
sgInitialFunds ShelleyGenesis (EraCrypto era)
genesis)
      , let txIn :: TxIn (EraCrypto era)
txIn = forall c. Crypto c => Addr c -> TxIn c
initialFundsPseudoTxIn Addr (EraCrypto era)
addr
            txOut :: TxOut era
txOut = forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
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 :: forall c. Crypto c => Addr c -> TxIn c
initialFundsPseudoTxIn :: forall c. Crypto c => Addr c -> TxIn c
initialFundsPseudoTxIn Addr c
addr =
  forall c. TxId c -> TxIx -> TxIn c
TxIn (Addr c -> TxId c
pseudoTxId Addr c
addr) forall a. Bounded a => a
minBound
  where
    pseudoTxId :: Addr c -> TxId c
pseudoTxId =
      forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c index. Hash (HASH c) index -> SafeHash c index
unsafeMakeSafeHash
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( forall h a b. Hash h a -> Hash h b
Crypto.castHash ::
              Crypto.Hash (HASH c) (Addr c) ->
              Crypto.Hash (HASH c) EraIndependentTxBody
          )
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Crypto.hashWith forall c. Addr c -> 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 ::
  forall c.
  Crypto c =>
  ShelleyGenesis c ->
  Either [ValidationErr] ()
validateGenesis :: forall c. Crypto c => ShelleyGenesis c -> Either [ValidationErr] ()
validateGenesis
  ShelleyGenesis
    { EpochSize
sgEpochLength :: EpochSize
sgEpochLength :: forall c. ShelleyGenesis c -> EpochSize
sgEpochLength
    , PositiveUnitInterval
sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff :: forall c. ShelleyGenesis c -> PositiveUnitInterval
sgActiveSlotsCoeff
    , Word64
sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions :: forall c. ShelleyGenesis c -> Word64
sgMaxKESEvolutions
    , Word64
sgSecurityParam :: Word64
sgSecurityParam :: forall c. ShelleyGenesis c -> Word64
sgSecurityParam
    , Word64
sgUpdateQuorum :: Word64
sgUpdateQuorum :: forall c. ShelleyGenesis c -> Word64
sgUpdateQuorum
    , Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs :: forall c.
ShelleyGenesis c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
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
* 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
                    Word64
sgSecurityParam
                    Rational
activeSlotsCoeff
                    EpochSize
minLength
              else forall a. Maybe a
Nothing
      checkKesEvolutions :: Maybe ValidationErr
checkKesEvolutions =
        if Word64
sgMaxKESEvolutions
          forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy @(KES c)))
          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
                (forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy @(KES c)))
      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 c) (GenDelegPair c)
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 c ->
  EpochInfo (Either Text) ->
  Globals
mkShelleyGlobals :: forall c. ShelleyGenesis c -> EpochInfo (Either Text) -> Globals
mkShelleyGlobals ShelleyGenesis c
genesis EpochInfo (Either Text)
epochInfoAc =
  Globals
    { activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff = forall c. ShelleyGenesis c -> ActiveSlotCoeff
sgActiveSlotCoeff ShelleyGenesis c
genesis
    , epochInfo :: EpochInfo (Either Text)
epochInfo = EpochInfo (Either Text)
epochInfoAc
    , maxKESEvo :: Word64
maxKESEvo = forall c. ShelleyGenesis c -> Word64
sgMaxKESEvolutions ShelleyGenesis c
genesis
    , maxLovelaceSupply :: Word64
maxLovelaceSupply = forall c. ShelleyGenesis c -> Word64
sgMaxLovelaceSupply ShelleyGenesis c
genesis
    , networkId :: Network
networkId = forall c. ShelleyGenesis c -> Network
sgNetworkId ShelleyGenesis c
genesis
    , quorum :: Word64
quorum = forall c. ShelleyGenesis c -> Word64
sgUpdateQuorum ShelleyGenesis c
genesis
    , Word64
randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow
    , securityParameter :: Word64
securityParameter = Word64
k
    , slotsPerKESPeriod :: Word64
slotsPerKESPeriod = forall c. ShelleyGenesis c -> Word64
sgSlotsPerKESPeriod ShelleyGenesis c
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
$ forall c. ShelleyGenesis c -> UTCTime
sgSystemStart ShelleyGenesis c
genesis
    k :: Word64
k = forall c. ShelleyGenesis c -> Word64
sgSecurityParam ShelleyGenesis c
genesis
    stabilityWindow :: Word64
stabilityWindow =
      Word64 -> ActiveSlotCoeff -> Word64
computeStabilityWindow Word64
k (forall c. ShelleyGenesis c -> ActiveSlotCoeff
sgActiveSlotCoeff ShelleyGenesis c
genesis)
    randomnessStabilisationWindow :: Word64
randomnessStabilisationWindow =
      Word64 -> ActiveSlotCoeff -> Word64
computeRandomnessStabilisationWindow Word64
k (forall c. ShelleyGenesis c -> ActiveSlotCoeff
sgActiveSlotCoeff ShelleyGenesis c
genesis)