{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.ThreadNet.Infra.Shelley (
    CoreNode (..)
  , CoreNodeKeyInfo (..)
  , DecentralizationParam (..)
  , KesConfig (..)
  , coreNodeKeys
  , genCoreNode
  , incrementMinorProtVer
  , initialLovelacePerCoreNode
  , mkCredential
  , mkEpochSize
  , mkGenesisConfig
  , mkKesConfig
  , mkKeyHash
  , mkKeyHashVrf
  , mkKeyPair
  , mkLeaderCredentials
  , mkMASetDecentralizationParamTxs
  , mkProtocolShelley
  , mkSetDecentralizationParamTxs
  , mkVerKey
  , networkId
  , tpraosSlotLength
  ) where

import           Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), seedSizeDSIGN)
import           Cardano.Crypto.Hash (Hash, HashAlgorithm)
import           Cardano.Crypto.KES (KESAlgorithm (..))
import           Cardano.Crypto.Seed (mkSeedFromBytes)
import qualified Cardano.Crypto.Seed as Cardano.Crypto
import           Cardano.Crypto.VRF (SignKeyVRF, VRFAlgorithm, VerKeyVRF,
                     deriveVerKeyVRF, genKeyVRF, seedSizeVRF)
import qualified Cardano.Ledger.Allegra.Scripts as SL
import           Cardano.Ledger.Alonzo (AlonzoEra)
import           Cardano.Ledger.BaseTypes (boundRational)
import           Cardano.Ledger.Crypto (Crypto, DSIGN, HASH, KES, VRF)
import           Cardano.Ledger.Hashes (EraIndependentTxBody)
import qualified Cardano.Ledger.Keys
import qualified Cardano.Ledger.Mary.Core as SL
import           Cardano.Ledger.SafeHash (HashAnnotated (..), SafeHash,
                     hashAnnotated)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Val as SL
import           Cardano.Protocol.TPraos.OCert
                     (OCert (ocertKESPeriod, ocertN, ocertSigma, ocertVkHot))
import qualified Cardano.Protocol.TPraos.OCert as SL (KESPeriod, OCert (OCert),
                     OCertSignable (..))
import           Control.Monad.Except (throwError)
import qualified Data.ByteString as BS
import           Data.Coerce (coerce)
import           Data.ListMap (ListMap (ListMap))
import qualified Data.ListMap as ListMap
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe.Strict (maybeToStrictMaybe)
import           Data.Ratio (denominator, numerator)
import qualified Data.Sequence.Strict as Seq
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           Lens.Micro
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config.SecurityParam
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Protocol.Praos.Common
                     (PraosCanBeLeader (PraosCanBeLeader),
                     praosCanBeLeaderColdVerKey, praosCanBeLeaderOpCert,
                     praosCanBeLeaderSignKeyVRF)
import           Ouroboros.Consensus.Protocol.TPraos
import           Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyEra)
import           Ouroboros.Consensus.Shelley.Ledger (GenTx (..),
                     ShelleyBasedEra, ShelleyBlock, ShelleyCompatible,
                     mkShelleyTx)
import           Ouroboros.Consensus.Shelley.Node
import           Ouroboros.Consensus.Util.Assert
import           Ouroboros.Consensus.Util.IOLike
import           Quiet (Quiet (..))
import qualified Test.Cardano.Ledger.Core.KeyPair as TL (KeyPair (..),
                     mkWitnessesVKey)
import qualified Test.Cardano.Ledger.Shelley.Generator.Core as Gen
import           Test.Cardano.Ledger.Shelley.Utils (unsafeBoundRational)
import           Test.QuickCheck
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Slots (NumSlots (..))
import           Test.Util.Time (dawnOfTime)

{-------------------------------------------------------------------------------
  The decentralization parameter
-------------------------------------------------------------------------------}

-- | A suitable value for the @d@ protocol parameter
--
-- In the range @0@ to @1@, inclusive. Beware the misnomer: @0@ means fully
-- decentralized, and @1@ means fully centralized.
newtype DecentralizationParam =
    DecentralizationParam {DecentralizationParam -> Rational
decentralizationParamToRational :: Rational }
  deriving (DecentralizationParam -> DecentralizationParam -> Bool
(DecentralizationParam -> DecentralizationParam -> Bool)
-> (DecentralizationParam -> DecentralizationParam -> Bool)
-> Eq DecentralizationParam
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecentralizationParam -> DecentralizationParam -> Bool
== :: DecentralizationParam -> DecentralizationParam -> Bool
$c/= :: DecentralizationParam -> DecentralizationParam -> Bool
/= :: DecentralizationParam -> DecentralizationParam -> Bool
Eq, (forall x. DecentralizationParam -> Rep DecentralizationParam x)
-> (forall x. Rep DecentralizationParam x -> DecentralizationParam)
-> Generic DecentralizationParam
forall x. Rep DecentralizationParam x -> DecentralizationParam
forall x. DecentralizationParam -> Rep DecentralizationParam x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DecentralizationParam -> Rep DecentralizationParam x
from :: forall x. DecentralizationParam -> Rep DecentralizationParam x
$cto :: forall x. Rep DecentralizationParam x -> DecentralizationParam
to :: forall x. Rep DecentralizationParam x -> DecentralizationParam
Generic, Eq DecentralizationParam
Eq DecentralizationParam =>
(DecentralizationParam -> DecentralizationParam -> Ordering)
-> (DecentralizationParam -> DecentralizationParam -> Bool)
-> (DecentralizationParam -> DecentralizationParam -> Bool)
-> (DecentralizationParam -> DecentralizationParam -> Bool)
-> (DecentralizationParam -> DecentralizationParam -> Bool)
-> (DecentralizationParam
    -> DecentralizationParam -> DecentralizationParam)
-> (DecentralizationParam
    -> DecentralizationParam -> DecentralizationParam)
-> Ord DecentralizationParam
DecentralizationParam -> DecentralizationParam -> Bool
DecentralizationParam -> DecentralizationParam -> Ordering
DecentralizationParam
-> DecentralizationParam -> DecentralizationParam
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
$ccompare :: DecentralizationParam -> DecentralizationParam -> Ordering
compare :: DecentralizationParam -> DecentralizationParam -> Ordering
$c< :: DecentralizationParam -> DecentralizationParam -> Bool
< :: DecentralizationParam -> DecentralizationParam -> Bool
$c<= :: DecentralizationParam -> DecentralizationParam -> Bool
<= :: DecentralizationParam -> DecentralizationParam -> Bool
$c> :: DecentralizationParam -> DecentralizationParam -> Bool
> :: DecentralizationParam -> DecentralizationParam -> Bool
$c>= :: DecentralizationParam -> DecentralizationParam -> Bool
>= :: DecentralizationParam -> DecentralizationParam -> Bool
$cmax :: DecentralizationParam
-> DecentralizationParam -> DecentralizationParam
max :: DecentralizationParam
-> DecentralizationParam -> DecentralizationParam
$cmin :: DecentralizationParam
-> DecentralizationParam -> DecentralizationParam
min :: DecentralizationParam
-> DecentralizationParam -> DecentralizationParam
Ord)
  deriving (Int -> DecentralizationParam -> ShowS
[DecentralizationParam] -> ShowS
DecentralizationParam -> String
(Int -> DecentralizationParam -> ShowS)
-> (DecentralizationParam -> String)
-> ([DecentralizationParam] -> ShowS)
-> Show DecentralizationParam
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecentralizationParam -> ShowS
showsPrec :: Int -> DecentralizationParam -> ShowS
$cshow :: DecentralizationParam -> String
show :: DecentralizationParam -> String
$cshowList :: [DecentralizationParam] -> ShowS
showList :: [DecentralizationParam] -> ShowS
Show) via (Quiet DecentralizationParam)

-- | A fraction with denominator @10@ and numerator @0@ to @10@ inclusive
instance Arbitrary DecentralizationParam where
  arbitrary :: Gen DecentralizationParam
arbitrary = do
      let d :: Integer
d = Integer
10
      Integer
n <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
d)
      DecentralizationParam -> Gen DecentralizationParam
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DecentralizationParam -> Gen DecentralizationParam)
-> DecentralizationParam -> Gen DecentralizationParam
forall a b. (a -> b) -> a -> b
$ Rational -> DecentralizationParam
DecentralizationParam (Rational -> DecentralizationParam)
-> Rational -> DecentralizationParam
forall a b. (a -> b) -> a -> b
$ Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
n Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
d

{-------------------------------------------------------------------------------
  Important constants
-------------------------------------------------------------------------------}

tpraosSlotLength :: SlotLength
tpraosSlotLength :: SlotLength
tpraosSlotLength = Integer -> SlotLength
slotLengthFromSec Integer
2

{-------------------------------------------------------------------------------
  CoreNode secrets/etc
-------------------------------------------------------------------------------}

data CoreNode c = CoreNode {
      forall c. CoreNode c -> SignKeyDSIGN c
cnGenesisKey  :: !(SL.SignKeyDSIGN c)
    , forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey :: !(SL.SignKeyDSIGN c)
      -- ^ Cold delegate key. The hash of the corresponding verification
      -- (public) key will be used as the payment credential.
    , forall c. CoreNode c -> SignKeyDSIGN c
cnStakingKey  :: !(SL.SignKeyDSIGN c)
      -- ^ The hash of the corresponding verification (public) key will be
      -- used as the staking credential.
    , forall c. CoreNode c -> SignKeyVRF c
cnVRF         :: !(SL.SignKeyVRF   c)
    , forall c. CoreNode c -> SignKeyKES c
cnKES         :: !(SL.SignKeyKES   c)
    , forall c. CoreNode c -> OCert c
cnOCert       :: !(SL.OCert        c)
    }

data CoreNodeKeyInfo c = CoreNodeKeyInfo
  { forall c.
CoreNodeKeyInfo c -> (KeyPair 'Payment c, KeyPair 'Staking c)
cnkiKeyPair
      ::  ( TL.KeyPair 'SL.Payment c
          , TL.KeyPair 'SL.Staking c
          )
  , forall c.
CoreNodeKeyInfo c
-> (KeyPair 'Genesis c, AllIssuerKeys c 'GenesisDelegate)
cnkiCoreNode ::
      ( TL.KeyPair 'SL.Genesis c
      , Gen.AllIssuerKeys c 'SL.GenesisDelegate
      )
  }

coreNodeKeys :: forall c. PraosCrypto c => CoreNode c -> CoreNodeKeyInfo c
coreNodeKeys :: forall c. PraosCrypto c => CoreNode c -> CoreNodeKeyInfo c
coreNodeKeys CoreNode{SignKeyDSIGN c
cnGenesisKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnGenesisKey :: SignKeyDSIGN c
cnGenesisKey, SignKeyDSIGN c
cnDelegateKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey :: SignKeyDSIGN c
cnDelegateKey, SignKeyDSIGN c
cnStakingKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnStakingKey :: SignKeyDSIGN c
cnStakingKey} =
    CoreNodeKeyInfo {
        cnkiCoreNode :: (KeyPair 'Genesis c, AllIssuerKeys c 'GenesisDelegate)
cnkiCoreNode =
          ( SignKeyDSIGN c -> KeyPair 'Genesis c
forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> KeyPair r c
mkKeyPair SignKeyDSIGN c
cnGenesisKey
          , Gen.AllIssuerKeys
            { aikCold :: KeyPair 'GenesisDelegate c
Gen.aikCold        = SignKeyDSIGN c -> KeyPair 'GenesisDelegate c
forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> KeyPair r c
mkKeyPair SignKeyDSIGN c
cnDelegateKey
              -- 'CoreNodeKeyInfo' is used for all sorts of generators, not
              -- only transaction generators. To generate transactions we
              -- don't need all these keys, hence the 'error's.
            , aikVrf :: VRFKeyPair c
Gen.aikVrf         = String -> VRFKeyPair c
forall a. HasCallStack => String -> a
error String
"vrf used while generating transactions"
            , aikHot :: NonEmpty (KESPeriod, KESKeyPair c)
Gen.aikHot         = String -> NonEmpty (KESPeriod, KESKeyPair c)
forall a. HasCallStack => String -> a
error String
"hot used while generating transactions"
            , aikColdKeyHash :: KeyHash 'GenesisDelegate c
Gen.aikColdKeyHash = String -> KeyHash 'GenesisDelegate c
forall a. HasCallStack => String -> a
error String
"hk used while generating transactions"
            }
          )
      , cnkiKeyPair :: (KeyPair 'Payment c, KeyPair 'Staking c)
cnkiKeyPair = (SignKeyDSIGN c -> KeyPair 'Payment c
forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> KeyPair r c
mkKeyPair SignKeyDSIGN c
cnDelegateKey, SignKeyDSIGN c -> KeyPair 'Staking c
forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> KeyPair r c
mkKeyPair SignKeyDSIGN c
cnStakingKey)
      }

genCoreNode ::
     forall c. PraosCrypto c
  => SL.KESPeriod
  -> Gen (CoreNode c)
genCoreNode :: forall c. PraosCrypto c => KESPeriod -> Gen (CoreNode c)
genCoreNode KESPeriod
startKESPeriod = do
    SignKeyDSIGN (DSIGN c)
genKey <- Seed -> SignKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (Seed -> SignKeyDSIGN (DSIGN c))
-> Gen Seed -> Gen (SignKeyDSIGN (DSIGN c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen Seed
forall a. Integral a => a -> Gen Seed
genSeed (Proxy (DSIGN c) -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
seedSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(DSIGN c)))
    SignKeyDSIGN (DSIGN c)
delKey <- Seed -> SignKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (Seed -> SignKeyDSIGN (DSIGN c))
-> Gen Seed -> Gen (SignKeyDSIGN (DSIGN c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen Seed
forall a. Integral a => a -> Gen Seed
genSeed (Proxy (DSIGN c) -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
seedSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(DSIGN c)))
    SignKeyDSIGN (DSIGN c)
stkKey <- Seed -> SignKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (Seed -> SignKeyDSIGN (DSIGN c))
-> Gen Seed -> Gen (SignKeyDSIGN (DSIGN c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen Seed
forall a. Integral a => a -> Gen Seed
genSeed (Proxy (DSIGN c) -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
seedSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(DSIGN c)))
    SignKeyVRF (VRF c)
vrfKey <- Seed -> SignKeyVRF (VRF c)
forall v. VRFAlgorithm v => Seed -> SignKeyVRF v
genKeyVRF   (Seed -> SignKeyVRF (VRF c))
-> Gen Seed -> Gen (SignKeyVRF (VRF c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen Seed
forall a. Integral a => a -> Gen Seed
genSeed (Proxy (VRF c) -> Word
forall v (proxy :: * -> *). VRFAlgorithm v => proxy v -> Word
forall (proxy :: * -> *). proxy (VRF c) -> Word
seedSizeVRF   (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(VRF   c)))
    SignKeyKES (KES c)
kesKey <- Seed -> SignKeyKES (KES c)
forall v. KESAlgorithm v => Seed -> SignKeyKES v
genKeyKES   (Seed -> SignKeyKES (KES c))
-> Gen Seed -> Gen (SignKeyKES (KES c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen Seed
forall a. Integral a => a -> Gen Seed
genSeed (Proxy (KES c) -> Word
forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
forall (proxy :: * -> *). proxy (KES c) -> Word
seedSizeKES   (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(KES   c)))
    let kesPub :: VerKeyKES (KES c)
kesPub = SignKeyKES (KES c) -> VerKeyKES (KES c)
forall v. KESAlgorithm v => SignKeyKES v -> VerKeyKES v
deriveVerKeyKES SignKeyKES (KES c)
kesKey
        sigma :: SignedDSIGN c (OCertSignable c)
sigma  = forall c a.
(Crypto c, Signable (DSIGN c) a) =>
SignKeyDSIGN (DSIGN c) -> a -> SignedDSIGN c a
Cardano.Ledger.Keys.signedDSIGN
          @c
          SignKeyDSIGN (DSIGN c)
delKey
          (VerKeyKES (KES c) -> Word64 -> KESPeriod -> OCertSignable c
forall c. VerKeyKES c -> Word64 -> KESPeriod -> OCertSignable c
SL.OCertSignable VerKeyKES (KES c)
kesPub Word64
certificateIssueNumber KESPeriod
startKESPeriod)
    let ocert :: OCert c
ocert = SL.OCert {
            ocertVkHot :: VerKeyKES (KES c)
ocertVkHot     = VerKeyKES (KES c)
kesPub
          , ocertN :: Word64
ocertN         = Word64
certificateIssueNumber
          , ocertKESPeriod :: KESPeriod
ocertKESPeriod = KESPeriod
startKESPeriod
          , ocertSigma :: SignedDSIGN c (OCertSignable c)
ocertSigma     = SignedDSIGN c (OCertSignable c)
sigma
          }
    CoreNode c -> Gen (CoreNode c)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreNode {
        cnGenesisKey :: SignKeyDSIGN (DSIGN c)
cnGenesisKey  = SignKeyDSIGN (DSIGN c)
genKey
      , cnDelegateKey :: SignKeyDSIGN (DSIGN c)
cnDelegateKey = SignKeyDSIGN (DSIGN c)
delKey
      , cnStakingKey :: SignKeyDSIGN (DSIGN c)
cnStakingKey  = SignKeyDSIGN (DSIGN c)
stkKey
      , cnVRF :: SignKeyVRF (VRF c)
cnVRF         = SignKeyVRF (VRF c)
vrfKey
      , cnKES :: SignKeyKES (KES c)
cnKES         = SignKeyKES (KES c)
kesKey
      , cnOCert :: OCert c
cnOCert       = OCert c
ocert
      }
  where
    certificateIssueNumber :: Word64
certificateIssueNumber = Word64
0

    genBytes :: Integral a => a -> Gen BS.ByteString
    genBytes :: forall a. Integral a => a -> Gen ByteString
genBytes a
nbBytes = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nbBytes) Gen Word8
forall a. Arbitrary a => Gen a
arbitrary

    genSeed :: Integral a => a -> Gen Cardano.Crypto.Seed
    genSeed :: forall a. Integral a => a -> Gen Seed
genSeed = (ByteString -> Seed) -> Gen ByteString -> Gen Seed
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Seed
mkSeedFromBytes (Gen ByteString -> Gen Seed)
-> (a -> Gen ByteString) -> a -> Gen Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Gen ByteString
forall a. Integral a => a -> Gen ByteString
genBytes

mkLeaderCredentials :: PraosCrypto c => CoreNode c -> ShelleyLeaderCredentials c
mkLeaderCredentials :: forall c. PraosCrypto c => CoreNode c -> ShelleyLeaderCredentials c
mkLeaderCredentials CoreNode { SignKeyDSIGN c
cnDelegateKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey :: SignKeyDSIGN c
cnDelegateKey, SignKeyVRF c
cnVRF :: forall c. CoreNode c -> SignKeyVRF c
cnVRF :: SignKeyVRF c
cnVRF, SignKeyKES c
cnKES :: forall c. CoreNode c -> SignKeyKES c
cnKES :: SignKeyKES c
cnKES, OCert c
cnOCert :: forall c. CoreNode c -> OCert c
cnOCert :: OCert c
cnOCert } =
    ShelleyLeaderCredentials {
        shelleyLeaderCredentialsInitSignKey :: SignKeyKES c
shelleyLeaderCredentialsInitSignKey = SignKeyKES c
cnKES
      , shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader {
          praosCanBeLeaderOpCert :: OCert c
praosCanBeLeaderOpCert     = OCert c
cnOCert
        , praosCanBeLeaderColdVerKey :: VKey 'BlockIssuer c
praosCanBeLeaderColdVerKey = VerKeyDSIGN (DSIGN c) -> VKey 'BlockIssuer c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> VKey 'BlockIssuer c)
-> VerKeyDSIGN (DSIGN c) -> VKey 'BlockIssuer c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN c -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN c
cnDelegateKey
        , praosCanBeLeaderSignKeyVRF :: SignKeyVRF c
praosCanBeLeaderSignKeyVRF = SignKeyVRF c
cnVRF
        }
      , shelleyLeaderCredentialsLabel :: Text
shelleyLeaderCredentialsLabel       = Text
"ThreadNet"
      }

{-------------------------------------------------------------------------------
  KES configuration
-------------------------------------------------------------------------------}

-- | Currently @'maxEvolutions' * 'slotsPerEvolution'@ is the max number of
-- slots the test can run without needing new ocerts.
--
-- TODO This limitation may be lifted by PR #2107, see
-- <https://github.com/IntersectMBO/ouroboros-network/issues/2107>.
data KesConfig = KesConfig
  { KesConfig -> Word64
maxEvolutions     :: Word64
  , KesConfig -> Word64
slotsPerEvolution :: Word64
  }

-- | A 'KesConfig' that will not require more evolutions than this test's crypto
-- allows.
mkKesConfig ::
     forall proxy c. Crypto c
  => proxy c -> NumSlots -> KesConfig
mkKesConfig :: forall (proxy :: * -> *) c.
Crypto c =>
proxy c -> NumSlots -> KesConfig
mkKesConfig proxy c
_ (NumSlots Word64
t) = KesConfig
    { Word64
maxEvolutions :: Word64
maxEvolutions :: Word64
maxEvolutions
    , slotsPerEvolution :: Word64
slotsPerEvolution = Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
divCeiling Word64
t Word64
maxEvolutions
    }
  where
    maxEvolutions :: Word64
maxEvolutions = Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word64) -> Word -> Word64
forall a b. (a -> b) -> a -> b
$ Proxy (KES c) -> Word
forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
forall (proxy :: * -> *). proxy (KES c) -> Word
totalPeriodsKES (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(KES c))

    -- | Like 'div', but rounds-up.
    divCeiling :: Integral a => a -> a -> a
    divCeiling :: forall a. Integral a => a -> a -> a
divCeiling a
n a
d = a
q a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a -> a
forall a. Ord a => a -> a -> a
min a
1 a
r
      where
        (a
q, a
r) = a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
quotRem a
n a
d

{-------------------------------------------------------------------------------
  TPraos node configuration
-------------------------------------------------------------------------------}

-- | The epoch size, given @k@ and @f@.
--
-- INVARIANT: @10 * k / f@ must be a whole number.
mkEpochSize :: SecurityParam -> Rational -> EpochSize
mkEpochSize :: SecurityParam -> Rational -> EpochSize
mkEpochSize (SecurityParam Word64
k) Rational
f =
    if Word64
r Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0 then String -> EpochSize
forall a. HasCallStack => String -> a
error String
"10 * k / f must be a whole number" else
    Word64 -> EpochSize
EpochSize Word64
q
  where
    n :: Integer
n = Rational -> Integer
forall a. Ratio a -> a
numerator   Rational
f
    d :: Integer
d = Rational -> Integer
forall a. Ratio a -> a
denominator Rational
f

    (Word64
q, Word64
r) = Word64 -> Word64 -> (Word64, Word64)
forall a. Integral a => a -> a -> (a, a)
quotRem (Word64
10 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
d) (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
n)

-- | Note: a KES algorithm supports a particular max number of KES evolutions,
-- but we can configure a potentially lower maximum for the ledger, that's why
-- we take it as an argument.
mkGenesisConfig ::
     forall c. PraosCrypto c
  => ProtVer   -- ^ Initial protocol version
  -> SecurityParam
  -> Rational  -- ^ Initial active slot coefficient
  -> DecentralizationParam
  -> Word64
     -- ^ Max Lovelace supply, must be >= #coreNodes * initialLovelacePerCoreNode
  -> SlotLength
  -> KesConfig
  -> [CoreNode c]
  -> ShelleyGenesis c
mkGenesisConfig :: forall c.
PraosCrypto c =>
ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode c]
-> ShelleyGenesis c
mkGenesisConfig ProtVer
pVer SecurityParam
k Rational
f DecentralizationParam
d Word64
maxLovelaceSupply SlotLength
slotLength KesConfig
kesCfg [CoreNode c]
coreNodes =
    Either String () -> ShelleyGenesis c -> ShelleyGenesis c
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg Either String ()
checkMaxLovelaceSupply (ShelleyGenesis c -> ShelleyGenesis c)
-> ShelleyGenesis c -> ShelleyGenesis c
forall a b. (a -> b) -> a -> b
$
    ShelleyGenesis {
      -- Matches the start of the ThreadNet tests
      sgSystemStart :: UTCTime
sgSystemStart           = UTCTime
dawnOfTime
    , sgNetworkMagic :: Word32
sgNetworkMagic          = Word32
0
    , sgNetworkId :: Network
sgNetworkId             = Network
networkId
    , sgActiveSlotsCoeff :: PositiveUnitInterval
sgActiveSlotsCoeff      = Rational -> PositiveUnitInterval
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational Rational
f
    , sgSecurityParam :: Word64
sgSecurityParam         = SecurityParam -> Word64
maxRollbacks SecurityParam
k
    , sgEpochLength :: EpochSize
sgEpochLength           = SecurityParam -> Rational -> EpochSize
mkEpochSize SecurityParam
k Rational
f
    , sgSlotsPerKESPeriod :: Word64
sgSlotsPerKESPeriod     = KesConfig -> Word64
slotsPerEvolution KesConfig
kesCfg
    , sgMaxKESEvolutions :: Word64
sgMaxKESEvolutions      = KesConfig -> Word64
maxEvolutions     KesConfig
kesCfg
    , sgSlotLength :: NominalDiffTimeMicro
sgSlotLength            = NominalDiffTime -> NominalDiffTimeMicro
SL.toNominalDiffTimeMicroWithRounding (NominalDiffTime -> NominalDiffTimeMicro)
-> NominalDiffTime -> NominalDiffTimeMicro
forall a b. (a -> b) -> a -> b
$ SlotLength -> NominalDiffTime
getSlotLength SlotLength
slotLength
    , sgUpdateQuorum :: Word64
sgUpdateQuorum          = Word64
quorum
    , sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply     = Word64
maxLovelaceSupply
    , sgProtocolParams :: PParams (ShelleyEra c)
sgProtocolParams        = PParams (ShelleyEra c)
pparams
    , sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs             = Map (KeyHash 'Genesis c) (GenDelegPair c)
coreNodesToGenesisMapping
    , sgInitialFunds :: ListMap (Addr c) Coin
sgInitialFunds          = Map (Addr c) Coin -> ListMap (Addr c) Coin
forall k v. Map k v -> ListMap k v
ListMap.fromMap Map (Addr c) Coin
initialFunds
    , sgStaking :: ShelleyGenesisStaking c
sgStaking               = ShelleyGenesisStaking c
initialStake
    }
  where
    checkMaxLovelaceSupply :: Either String ()
    checkMaxLovelaceSupply :: Either String ()
checkMaxLovelaceSupply
      | Word64
maxLovelaceSupply Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>=
        Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CoreNode c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreNode c]
coreNodes) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
initialLovelacePerCoreNode
      = () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise
      = String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [
            String
"Lovelace supply ="
          , Word64 -> String
forall a. Show a => a -> String
show Word64
maxLovelaceSupply
          , String
"but must be at least"
          , Word64 -> String
forall a. Show a => a -> String
show (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CoreNode c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreNode c]
coreNodes) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
initialLovelacePerCoreNode)
          ]

    quorum :: Word64
    quorum :: Word64
quorum = Word64
nbCoreNodes Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
`min` ((Word64
nbCoreNodes Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
2) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
      where
        nbCoreNodes :: Word64
nbCoreNodes = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CoreNode c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreNode c]
coreNodes)

    pparams :: SL.PParams (ShelleyEra c)
    pparams :: PParams (ShelleyEra c)
pparams = PParams (ShelleyEra c)
forall era. EraPParams era => PParams era
SL.emptyPParams
      PParams (ShelleyEra c)
-> (PParams (ShelleyEra c) -> PParams (ShelleyEra c))
-> PParams (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (UnitInterval -> Identity UnitInterval)
-> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c))
forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
Lens' (PParams (ShelleyEra c)) UnitInterval
SL.ppDL               ((UnitInterval -> Identity UnitInterval)
 -> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c)))
-> UnitInterval -> PParams (ShelleyEra c) -> PParams (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~
          Rational -> UnitInterval
forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational (DecentralizationParam -> Rational
decentralizationParamToRational DecentralizationParam
d)
      PParams (ShelleyEra c)
-> (PParams (ShelleyEra c) -> PParams (ShelleyEra c))
-> PParams (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c))
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams (ShelleyEra c)) Word32
SL.ppMaxBBSizeL       ((Word32 -> Identity Word32)
 -> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c)))
-> Word32 -> PParams (ShelleyEra c) -> PParams (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
10000 -- TODO
      PParams (ShelleyEra c)
-> (PParams (ShelleyEra c) -> PParams (ShelleyEra c))
-> PParams (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (Word16 -> Identity Word16)
-> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c))
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams (ShelleyEra c)) Word16
SL.ppMaxBHSizeL       ((Word16 -> Identity Word16)
 -> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c)))
-> Word16 -> PParams (ShelleyEra c) -> PParams (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16
1000 -- TODO
      PParams (ShelleyEra c)
-> (PParams (ShelleyEra c) -> PParams (ShelleyEra c))
-> PParams (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (ProtVer -> Identity ProtVer)
-> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c))
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams (ShelleyEra c)) ProtVer
SL.ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> PParams (ShelleyEra c) -> Identity (PParams (ShelleyEra c)))
-> ProtVer -> PParams (ShelleyEra c) -> PParams (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer
pVer

    coreNodesToGenesisMapping ::
         Map (SL.KeyHash 'SL.Genesis c) (SL.GenDelegPair c)
    coreNodesToGenesisMapping :: Map (KeyHash 'Genesis c) (GenDelegPair c)
coreNodesToGenesisMapping  = [(KeyHash 'Genesis c, GenDelegPair c)]
-> Map (KeyHash 'Genesis c) (GenDelegPair c)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ let
          gkh :: SL.KeyHash 'SL.Genesis c
          gkh :: KeyHash 'Genesis c
gkh = VKey 'Genesis c -> KeyHash 'Genesis c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'Genesis c -> KeyHash 'Genesis c)
-> (VerKeyDSIGN (DSIGN c) -> VKey 'Genesis c)
-> VerKeyDSIGN (DSIGN c)
-> KeyHash 'Genesis c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN (DSIGN c) -> VKey 'Genesis c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> KeyHash 'Genesis c)
-> VerKeyDSIGN (DSIGN c) -> KeyHash 'Genesis c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
cnGenesisKey

          gdpair :: SL.GenDelegPair c
          gdpair :: GenDelegPair c
gdpair = KeyHash 'GenesisDelegate c
-> Hash c (VerKeyVRF c) -> GenDelegPair c
forall c.
KeyHash 'GenesisDelegate c
-> Hash c (VerKeyVRF c) -> GenDelegPair c
SL.GenDelegPair
              (VKey 'GenesisDelegate c -> KeyHash 'GenesisDelegate c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'GenesisDelegate c -> KeyHash 'GenesisDelegate c)
-> (VerKeyDSIGN (DSIGN c) -> VKey 'GenesisDelegate c)
-> VerKeyDSIGN (DSIGN c)
-> KeyHash 'GenesisDelegate c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN (DSIGN c) -> VKey 'GenesisDelegate c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> KeyHash 'GenesisDelegate c)
-> VerKeyDSIGN (DSIGN c) -> KeyHash 'GenesisDelegate c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
cnDelegateKey)
              (VerKeyVRF c -> Hash c (VerKeyVRF c)
forall h. HashAlgorithm h => VerKeyVRF c -> Hash h (VerKeyVRF c)
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
SL.hashVerKeyVRF (VerKeyVRF c -> Hash c (VerKeyVRF c))
-> VerKeyVRF c -> Hash c (VerKeyVRF c)
forall a b. (a -> b) -> a -> b
$ SignKeyVRF (VRF c) -> VerKeyVRF c
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF SignKeyVRF (VRF c)
cnVRF)

        in (KeyHash 'Genesis c
gkh, GenDelegPair c
gdpair)
      | CoreNode { SignKeyDSIGN (DSIGN c)
cnGenesisKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnGenesisKey :: SignKeyDSIGN (DSIGN c)
cnGenesisKey, SignKeyDSIGN (DSIGN c)
cnDelegateKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey :: SignKeyDSIGN (DSIGN c)
cnDelegateKey, SignKeyVRF (VRF c)
cnVRF :: forall c. CoreNode c -> SignKeyVRF c
cnVRF :: SignKeyVRF (VRF c)
cnVRF } <- [CoreNode c]
coreNodes
      ]

    initialFunds :: Map (SL.Addr c) SL.Coin
    initialFunds :: Map (Addr c) Coin
initialFunds = [(Addr c, Coin)] -> Map (Addr c) Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Addr c
addr, Coin
coin)
      | CoreNode { SignKeyDSIGN (DSIGN c)
cnDelegateKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey :: SignKeyDSIGN (DSIGN c)
cnDelegateKey, SignKeyDSIGN (DSIGN c)
cnStakingKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnStakingKey :: SignKeyDSIGN (DSIGN c)
cnStakingKey } <- [CoreNode c]
coreNodes
      , let addr :: Addr c
addr = Network -> PaymentCredential c -> StakeReference c -> Addr c
forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
SL.Addr Network
networkId
                           (SignKeyDSIGN (DSIGN c) -> PaymentCredential c
forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential SignKeyDSIGN (DSIGN c)
cnDelegateKey)
                           (StakeCredential c -> StakeReference c
forall c. StakeCredential c -> StakeReference c
SL.StakeRefBase (SignKeyDSIGN (DSIGN c) -> StakeCredential c
forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential SignKeyDSIGN (DSIGN c)
cnStakingKey))
            coin :: Coin
coin = Integer -> Coin
SL.Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
initialLovelacePerCoreNode
      ]

    -- In this initial stake, each core node delegates its stake to itself.
    initialStake :: ShelleyGenesisStaking c
    initialStake :: ShelleyGenesisStaking c
initialStake = ShelleyGenesisStaking
      { sgsPools :: ListMap (KeyHash 'StakePool c) (PoolParams c)
sgsPools = [(KeyHash 'StakePool c, PoolParams c)]
-> ListMap (KeyHash 'StakePool c) (PoolParams c)
forall k v. [(k, v)] -> ListMap k v
ListMap
          [ (KeyHash 'StakePool c
pk, PoolParams c
pp)
          | pp :: PoolParams c
pp@SL.PoolParams { ppId :: forall c. PoolParams c -> KeyHash 'StakePool c
ppId = KeyHash 'StakePool c
pk } <- Map (KeyHash 'StakePool c) (PoolParams c) -> [PoolParams c]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'StakePool c) (PoolParams c)
coreNodeToPoolMapping
          ]
        -- The staking key maps to the key hash of the pool, which is set to the
        -- "delegate key" in order that nodes may issue blocks both as delegates
        -- and as stake pools.
      , sgsStake :: ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
sgsStake = [(KeyHash 'Staking c, KeyHash 'StakePool c)]
-> ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
forall k v. [(k, v)] -> ListMap k v
ListMap
          [ ( VKey 'Staking c -> KeyHash 'Staking c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'Staking c -> KeyHash 'Staking c)
-> (VerKeyDSIGN (DSIGN c) -> VKey 'Staking c)
-> VerKeyDSIGN (DSIGN c)
-> KeyHash 'Staking c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN (DSIGN c) -> VKey 'Staking c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> KeyHash 'Staking c)
-> VerKeyDSIGN (DSIGN c) -> KeyHash 'Staking c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
cnStakingKey
            , VKey 'StakePool c -> KeyHash 'StakePool c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'StakePool c -> KeyHash 'StakePool c)
-> (VerKeyDSIGN (DSIGN c) -> VKey 'StakePool c)
-> VerKeyDSIGN (DSIGN c)
-> KeyHash 'StakePool c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN (DSIGN c) -> VKey 'StakePool c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> KeyHash 'StakePool c)
-> VerKeyDSIGN (DSIGN c) -> KeyHash 'StakePool c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
cnDelegateKey
            )
          | CoreNode {SignKeyDSIGN (DSIGN c)
cnDelegateKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey :: SignKeyDSIGN (DSIGN c)
cnDelegateKey, SignKeyDSIGN (DSIGN c)
cnStakingKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnStakingKey :: SignKeyDSIGN (DSIGN c)
cnStakingKey} <- [CoreNode c]
coreNodes
          ]
      }
      where
        coreNodeToPoolMapping ::
             Map (SL.KeyHash 'SL.StakePool c) (SL.PoolParams c)
        coreNodeToPoolMapping :: Map (KeyHash 'StakePool c) (PoolParams c)
coreNodeToPoolMapping = [(KeyHash 'StakePool c, PoolParams c)]
-> Map (KeyHash 'StakePool c) (PoolParams c)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
              ( VKey 'StakePool c -> KeyHash 'StakePool c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'StakePool c -> KeyHash 'StakePool c)
-> (SignKeyDSIGN (DSIGN c) -> VKey 'StakePool c)
-> SignKeyDSIGN (DSIGN c)
-> KeyHash 'StakePool c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN (DSIGN c) -> VKey 'StakePool c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> VKey 'StakePool c)
-> (SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c))
-> SignKeyDSIGN (DSIGN c)
-> VKey 'StakePool c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN (SignKeyDSIGN (DSIGN c) -> KeyHash 'StakePool c)
-> SignKeyDSIGN (DSIGN c) -> KeyHash 'StakePool c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c)
cnStakingKey
              , SL.PoolParams
                { ppId :: KeyHash 'StakePool c
SL.ppId = KeyHash 'StakePool c
poolHash
                , ppVrf :: Hash c (VerKeyVRF c)
SL.ppVrf = Hash c (VerKeyVRF c)
vrfHash
                  -- Each core node pledges its full stake to the pool.
                , ppPledge :: Coin
SL.ppPledge = Integer -> Coin
SL.Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
initialLovelacePerCoreNode
                , ppCost :: Coin
SL.ppCost = Integer -> Coin
SL.Coin Integer
1
                , ppMargin :: UnitInterval
SL.ppMargin = UnitInterval
forall a. Bounded a => a
minBound
                  -- Reward accounts live in a separate "namespace" to other
                  -- accounts, so it should be fine to use the same address.
                , ppRewardAccount :: RewardAccount c
SL.ppRewardAccount = Network -> StakeCredential c -> RewardAccount c
forall c. Network -> Credential 'Staking c -> RewardAccount c
SL.RewardAccount Network
networkId (StakeCredential c -> RewardAccount c)
-> StakeCredential c -> RewardAccount c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c) -> StakeCredential c
forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential SignKeyDSIGN (DSIGN c)
cnDelegateKey
                , ppOwners :: Set (KeyHash 'Staking c)
SL.ppOwners = KeyHash 'Staking c -> Set (KeyHash 'Staking c)
forall a. a -> Set a
Set.singleton KeyHash 'Staking c
poolOwnerHash
                , ppRelays :: StrictSeq StakePoolRelay
SL.ppRelays = StrictSeq StakePoolRelay
forall a. StrictSeq a
Seq.empty
                , ppMetadata :: StrictMaybe PoolMetadata
SL.ppMetadata = StrictMaybe PoolMetadata
forall a. StrictMaybe a
SL.SNothing
                }
              )
            | CoreNode { SignKeyDSIGN (DSIGN c)
cnDelegateKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey :: SignKeyDSIGN (DSIGN c)
cnDelegateKey, SignKeyDSIGN (DSIGN c)
cnStakingKey :: forall c. CoreNode c -> SignKeyDSIGN c
cnStakingKey :: SignKeyDSIGN (DSIGN c)
cnStakingKey, SignKeyVRF (VRF c)
cnVRF :: forall c. CoreNode c -> SignKeyVRF c
cnVRF :: SignKeyVRF (VRF c)
cnVRF } <- [CoreNode c]
coreNodes
              -- The pool and owner hashes are derived from the same key, but
              -- use different hashing schemes
            , let poolHash :: KeyHash 'StakePool c
poolHash = VKey 'StakePool c -> KeyHash 'StakePool c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'StakePool c -> KeyHash 'StakePool c)
-> (VerKeyDSIGN (DSIGN c) -> VKey 'StakePool c)
-> VerKeyDSIGN (DSIGN c)
-> KeyHash 'StakePool c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN (DSIGN c) -> VKey 'StakePool c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> KeyHash 'StakePool c)
-> VerKeyDSIGN (DSIGN c) -> KeyHash 'StakePool c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
cnDelegateKey
            , let poolOwnerHash :: KeyHash 'Staking c
poolOwnerHash = VKey 'Staking c -> KeyHash 'Staking c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'Staking c -> KeyHash 'Staking c)
-> (VerKeyDSIGN (DSIGN c) -> VKey 'Staking c)
-> VerKeyDSIGN (DSIGN c)
-> KeyHash 'Staking c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN (DSIGN c) -> VKey 'Staking c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> KeyHash 'Staking c)
-> VerKeyDSIGN (DSIGN c) -> KeyHash 'Staking c
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
cnDelegateKey
            , let vrfHash :: Hash c (VerKeyVRF c)
vrfHash = VerKeyVRF c -> Hash c (VerKeyVRF c)
forall h. HashAlgorithm h => VerKeyVRF c -> Hash h (VerKeyVRF c)
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
SL.hashVerKeyVRF (VerKeyVRF c -> Hash c (VerKeyVRF c))
-> VerKeyVRF c -> Hash c (VerKeyVRF c)
forall a b. (a -> b) -> a -> b
$ SignKeyVRF (VRF c) -> VerKeyVRF c
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF SignKeyVRF (VRF c)
cnVRF
            ]

mkProtocolShelley ::
     forall m c.
     (IOLike m, PraosCrypto c, ShelleyCompatible (TPraos c) (ShelleyEra c))
  => ShelleyGenesis c
  -> SL.Nonce
  -> ProtVer
  -> CoreNode c
  -> ( ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c))
     , m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))]
     )
mkProtocolShelley :: forall (m :: * -> *) c.
(IOLike m, PraosCrypto c,
 ShelleyCompatible (TPraos c) (ShelleyEra c)) =>
ShelleyGenesis c
-> Nonce
-> ProtVer
-> CoreNode c
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
mkProtocolShelley ShelleyGenesis c
genesis Nonce
initialNonce ProtVer
protVer CoreNode c
coreNode =
    ShelleyGenesis c
-> ProtocolParamsShelleyBased c
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
forall (m :: * -> *) c.
(IOLike m, PraosCrypto c,
 ShelleyCompatible (TPraos c) (ShelleyEra c),
 TxLimits (ShelleyBlock (TPraos c) (ShelleyEra c))) =>
ShelleyGenesis c
-> ProtocolParamsShelleyBased c
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
protocolInfoShelley
      ShelleyGenesis c
genesis
      ProtocolParamsShelleyBased {
          shelleyBasedInitialNonce :: Nonce
shelleyBasedInitialNonce      = Nonce
initialNonce
        , shelleyBasedLeaderCredentials :: [ShelleyLeaderCredentials c]
shelleyBasedLeaderCredentials = [CoreNode c -> ShelleyLeaderCredentials c
forall c. PraosCrypto c => CoreNode c -> ShelleyLeaderCredentials c
mkLeaderCredentials CoreNode c
coreNode]
        }
      ProtVer
protVer
{-------------------------------------------------------------------------------
  Necessary transactions for updating the 'DecentralizationParam'
-------------------------------------------------------------------------------}

incrementMinorProtVer :: SL.ProtVer -> SL.ProtVer
incrementMinorProtVer :: ProtVer -> ProtVer
incrementMinorProtVer (SL.ProtVer Version
major Natural
minor) = Version -> Natural -> ProtVer
SL.ProtVer Version
major (Natural -> Natural
forall a. Enum a => a -> a
succ Natural
minor)

mkSetDecentralizationParamTxs ::
     forall c. (ShelleyBasedEra (ShelleyEra c))
  => [CoreNode c]
  -> ProtVer   -- ^ The proposed protocol version
  -> SlotNo   -- ^ The TTL
  -> DecentralizationParam   -- ^ The new value
  -> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))]
mkSetDecentralizationParamTxs :: forall c.
ShelleyBasedEra (ShelleyEra c) =>
[CoreNode c]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))]
mkSetDecentralizationParamTxs [CoreNode c]
coreNodes ProtVer
pVer SlotNo
ttl DecentralizationParam
dNew =
    (GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))
-> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))]
-> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))]
forall a. a -> [a] -> [a]
:[]) (GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))
 -> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))])
-> GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))
-> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))]
forall a b. (a -> b) -> a -> b
$
    Tx (ShelleyEra c) -> GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx (Tx (ShelleyEra c)
 -> GenTx (ShelleyBlock (TPraos c) (ShelleyEra c)))
-> Tx (ShelleyEra c)
-> GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))
forall a b. (a -> b) -> a -> b
$
    TxBody (ShelleyEra c) -> Tx (ShelleyEra c)
forall era. EraTx era => TxBody era -> Tx era
SL.mkBasicTx TxBody (ShelleyEra c)
body Tx (ShelleyEra c)
-> (Tx (ShelleyEra c) -> ShelleyTx (ShelleyEra c))
-> ShelleyTx (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (TxWits (ShelleyEra c) -> Identity (TxWits (ShelleyEra c)))
-> Tx (ShelleyEra c) -> Identity (Tx (ShelleyEra c))
(TxWits (ShelleyEra c) -> Identity (TxWits (ShelleyEra c)))
-> Tx (ShelleyEra c) -> Identity (ShelleyTx (ShelleyEra c))
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx (ShelleyEra c)) (TxWits (ShelleyEra c))
SL.witsTxL ((TxWits (ShelleyEra c) -> Identity (TxWits (ShelleyEra c)))
 -> Tx (ShelleyEra c) -> Identity (ShelleyTx (ShelleyEra c)))
-> TxWits (ShelleyEra c)
-> Tx (ShelleyEra c)
-> ShelleyTx (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits (ShelleyEra c)
witnesses
  where
    -- The funds touched by this transaction assume it's the first transaction
    -- executed.
    scheduledEpoch :: EpochNo
    scheduledEpoch :: EpochNo
scheduledEpoch = Word64 -> EpochNo
EpochNo Word64
0


    witnesses :: SL.TxWits (ShelleyEra c)
    witnesses :: TxWits (ShelleyEra c)
witnesses = TxWits (ShelleyEra c)
forall era. EraTxWits era => TxWits era
SL.mkBasicTxWits TxWits (ShelleyEra c)
-> (TxWits (ShelleyEra c) -> ShelleyTxWits (ShelleyEra c))
-> ShelleyTxWits (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (Set (WitVKey 'Witness (EraCrypto (ShelleyEra c)))
 -> Identity (Set (WitVKey 'Witness c)))
-> TxWits (ShelleyEra c) -> Identity (ShelleyTxWits (ShelleyEra c))
(Set (WitVKey 'Witness (EraCrypto (ShelleyEra c)))
 -> Identity (Set (WitVKey 'Witness (EraCrypto (ShelleyEra c)))))
-> TxWits (ShelleyEra c) -> Identity (TxWits (ShelleyEra c))
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
Lens'
  (TxWits (ShelleyEra c))
  (Set (WitVKey 'Witness (EraCrypto (ShelleyEra c))))
SL.addrTxWitsL ((Set (WitVKey 'Witness (EraCrypto (ShelleyEra c)))
  -> Identity (Set (WitVKey 'Witness c)))
 -> TxWits (ShelleyEra c)
 -> Identity (ShelleyTxWits (ShelleyEra c)))
-> Set (WitVKey 'Witness c)
-> TxWits (ShelleyEra c)
-> ShelleyTxWits (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness c)
signatures

    -- Every node signs the transaction body, since it includes a " vote " from
    -- every node.
    signatures :: Set (SL.WitVKey 'SL.Witness c)
    signatures :: Set (WitVKey 'Witness c)
signatures =
        SafeHash c EraIndependentTxBody
-> [KeyPair Any c] -> Set (WitVKey 'Witness c)
forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
TL.mkWitnessesVKey
          (ShelleyTxBody (ShelleyEra c) -> SafeHash c EraIndependentTxBody
forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody (ShelleyEra c)
ShelleyTxBody (ShelleyEra c)
body)
          [ VKey Any c -> SignKeyDSIGN (DSIGN c) -> KeyPair Any c
forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
TL.KeyPair (VerKeyDSIGN (DSIGN c) -> VKey Any c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey VerKeyDSIGN (DSIGN c)
vk) SignKeyDSIGN (DSIGN c)
sk
          | CoreNode c
cn <- [CoreNode c]
coreNodes
          , let sk :: SignKeyDSIGN (DSIGN c)
sk = CoreNode c -> SignKeyDSIGN (DSIGN c)
forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey CoreNode c
cn
          , let vk :: VerKeyDSIGN (DSIGN c)
vk = SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN c)
sk
          ]

    -- Nothing but the parameter update and the obligatory touching of an
    -- input.
    body :: SL.TxBody (ShelleyEra c)
    body :: TxBody (ShelleyEra c)
body = TxBody (ShelleyEra c)
forall era. EraTxBody era => TxBody era
SL.mkBasicTxBody
         TxBody (ShelleyEra c)
-> (TxBody (ShelleyEra c) -> TxBody (ShelleyEra c))
-> TxBody (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (Set (TxIn (EraCrypto (ShelleyEra c))) -> Identity (Set (TxIn c)))
-> TxBody (ShelleyEra c) -> Identity (TxBody (ShelleyEra c))
(Set (TxIn (EraCrypto (ShelleyEra c)))
 -> Identity (Set (TxIn (EraCrypto (ShelleyEra c)))))
-> TxBody (ShelleyEra c) -> Identity (TxBody (ShelleyEra c))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody (ShelleyEra c)) (Set (TxIn (EraCrypto (ShelleyEra c))))
SL.inputsTxBodyL  ((Set (TxIn (EraCrypto (ShelleyEra c))) -> Identity (Set (TxIn c)))
 -> TxBody (ShelleyEra c) -> Identity (TxBody (ShelleyEra c)))
-> Set (TxIn c) -> TxBody (ShelleyEra c) -> TxBody (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn c -> Set (TxIn c)
forall a. a -> Set a
Set.singleton ((TxIn c, ShelleyTxOut (ShelleyEra c)) -> TxIn c
forall a b. (a, b) -> a
fst (TxIn c, TxOut (ShelleyEra c))
(TxIn c, ShelleyTxOut (ShelleyEra c))
touchCoins)
         TxBody (ShelleyEra c)
-> (TxBody (ShelleyEra c) -> TxBody (ShelleyEra c))
-> TxBody (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut (ShelleyEra c))
 -> Identity (StrictSeq (TxOut (ShelleyEra c))))
-> TxBody (ShelleyEra c) -> Identity (TxBody (ShelleyEra c))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody (ShelleyEra c)) (StrictSeq (TxOut (ShelleyEra c)))
SL.outputsTxBodyL ((StrictSeq (TxOut (ShelleyEra c))
  -> Identity (StrictSeq (TxOut (ShelleyEra c))))
 -> TxBody (ShelleyEra c) -> Identity (TxBody (ShelleyEra c)))
-> StrictSeq (TxOut (ShelleyEra c))
-> TxBody (ShelleyEra c)
-> TxBody (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut (ShelleyEra c) -> StrictSeq (TxOut (ShelleyEra c))
forall a. a -> StrictSeq a
Seq.singleton ((TxIn c, TxOut (ShelleyEra c)) -> TxOut (ShelleyEra c)
forall a b. (a, b) -> b
snd (TxIn c, TxOut (ShelleyEra c))
touchCoins)
         TxBody (ShelleyEra c)
-> (TxBody (ShelleyEra c) -> ShelleyTxBody (ShelleyEra c))
-> ShelleyTxBody (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (SlotNo -> Identity SlotNo)
-> TxBody (ShelleyEra c) -> Identity (TxBody (ShelleyEra c))
(SlotNo -> Identity SlotNo)
-> TxBody (ShelleyEra c) -> Identity (ShelleyTxBody (ShelleyEra c))
forall era.
(ShelleyEraTxBody era, ExactEra ShelleyEra era) =>
Lens' (TxBody era) SlotNo
Lens' (TxBody (ShelleyEra c)) SlotNo
SL.ttlTxBodyL     ((SlotNo -> Identity SlotNo)
 -> TxBody (ShelleyEra c)
 -> Identity (ShelleyTxBody (ShelleyEra c)))
-> SlotNo -> TxBody (ShelleyEra c) -> ShelleyTxBody (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SlotNo
ttl
         ShelleyTxBody (ShelleyEra c)
-> (ShelleyTxBody (ShelleyEra c) -> ShelleyTxBody (ShelleyEra c))
-> ShelleyTxBody (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Update (ShelleyEra c))
 -> Identity (StrictMaybe (Update (ShelleyEra c))))
-> TxBody (ShelleyEra c) -> Identity (TxBody (ShelleyEra c))
(StrictMaybe (Update (ShelleyEra c))
 -> Identity (StrictMaybe (Update (ShelleyEra c))))
-> ShelleyTxBody (ShelleyEra c)
-> Identity (ShelleyTxBody (ShelleyEra c))
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
Lens' (TxBody (ShelleyEra c)) (StrictMaybe (Update (ShelleyEra c)))
SL.updateTxBodyL ((StrictMaybe (Update (ShelleyEra c))
  -> Identity (StrictMaybe (Update (ShelleyEra c))))
 -> ShelleyTxBody (ShelleyEra c)
 -> Identity (ShelleyTxBody (ShelleyEra c)))
-> StrictMaybe (Update (ShelleyEra c))
-> ShelleyTxBody (ShelleyEra c)
-> ShelleyTxBody (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Update (ShelleyEra c) -> StrictMaybe (Update (ShelleyEra c))
forall a. a -> StrictMaybe a
SL.SJust Update (ShelleyEra c)
update

    -- Every Shelley transaction requires one input.
    --
    -- We use the input of the first node, but we just put it all right back.
    --
    -- ASSUMPTION: This transaction runs in the first slot.
    touchCoins :: (SL.TxIn c, SL.TxOut (ShelleyEra c))
    touchCoins :: (TxIn c, TxOut (ShelleyEra c))
touchCoins = case [CoreNode c]
coreNodes of
        []   -> String -> (TxIn c, ShelleyTxOut (ShelleyEra c))
forall a. HasCallStack => String -> a
error String
"no nodes!"
        CoreNode c
cn:[CoreNode c]
_ ->
            ( Addr c -> TxIn c
forall c. Crypto c => Addr c -> TxIn c
SL.initialFundsPseudoTxIn Addr c
addr
            , Addr (EraCrypto (ShelleyEra c))
-> Value (ShelleyEra c) -> ShelleyTxOut (ShelleyEra c)
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
SL.ShelleyTxOut Addr c
Addr (EraCrypto (ShelleyEra c))
addr Value (ShelleyEra c)
Coin
coin
            )
          where
            addr :: Addr c
addr = Network -> PaymentCredential c -> StakeReference c -> Addr c
forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
SL.Addr Network
networkId
                (SignKeyDSIGN (DSIGN c) -> PaymentCredential c
forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential (CoreNode c -> SignKeyDSIGN (DSIGN c)
forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey CoreNode c
cn))
                (StakeCredential c -> StakeReference c
forall c. StakeCredential c -> StakeReference c
SL.StakeRefBase (SignKeyDSIGN (DSIGN c) -> StakeCredential c
forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential (CoreNode c -> SignKeyDSIGN (DSIGN c)
forall c. CoreNode c -> SignKeyDSIGN c
cnStakingKey CoreNode c
cn)))
            coin :: Coin
coin = Integer -> Coin
SL.Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
initialLovelacePerCoreNode

    -- One replicant of the parameter update per each node.
    update :: SL.Update (ShelleyEra c)
    update :: Update (ShelleyEra c)
update =
        (ProposedPPUpdates (ShelleyEra c)
 -> EpochNo -> Update (ShelleyEra c))
-> EpochNo
-> ProposedPPUpdates (ShelleyEra c)
-> Update (ShelleyEra c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProposedPPUpdates (ShelleyEra c)
-> EpochNo -> Update (ShelleyEra c)
forall era. ProposedPPUpdates era -> EpochNo -> Update era
SL.Update EpochNo
scheduledEpoch (ProposedPPUpdates (ShelleyEra c) -> Update (ShelleyEra c))
-> ProposedPPUpdates (ShelleyEra c) -> Update (ShelleyEra c)
forall a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Genesis (EraCrypto (ShelleyEra c)))
  (PParamsUpdate (ShelleyEra c))
-> ProposedPPUpdates (ShelleyEra c)
forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
SL.ProposedPPUpdates (Map
   (KeyHash 'Genesis (EraCrypto (ShelleyEra c)))
   (PParamsUpdate (ShelleyEra c))
 -> ProposedPPUpdates (ShelleyEra c))
-> Map
     (KeyHash 'Genesis (EraCrypto (ShelleyEra c)))
     (PParamsUpdate (ShelleyEra c))
-> ProposedPPUpdates (ShelleyEra c)
forall a b. (a -> b) -> a -> b
$
        [(KeyHash 'Genesis (EraCrypto (ShelleyEra c)),
  PParamsUpdate (ShelleyEra c))]
-> Map
     (KeyHash 'Genesis (EraCrypto (ShelleyEra c)))
     (PParamsUpdate (ShelleyEra c))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(KeyHash 'Genesis (EraCrypto (ShelleyEra c)),
   PParamsUpdate (ShelleyEra c))]
 -> Map
      (KeyHash 'Genesis (EraCrypto (ShelleyEra c)))
      (PParamsUpdate (ShelleyEra c)))
-> [(KeyHash 'Genesis (EraCrypto (ShelleyEra c)),
     PParamsUpdate (ShelleyEra c))]
-> Map
     (KeyHash 'Genesis (EraCrypto (ShelleyEra c)))
     (PParamsUpdate (ShelleyEra c))
forall a b. (a -> b) -> a -> b
$
        [ ( VKey 'Genesis (EraCrypto (ShelleyEra c))
-> KeyHash 'Genesis (EraCrypto (ShelleyEra c))
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'Genesis (EraCrypto (ShelleyEra c))
 -> KeyHash 'Genesis (EraCrypto (ShelleyEra c)))
-> VKey 'Genesis (EraCrypto (ShelleyEra c))
-> KeyHash 'Genesis (EraCrypto (ShelleyEra c))
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
-> VKey 'Genesis (EraCrypto (ShelleyEra c))
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
 -> VKey 'Genesis (EraCrypto (ShelleyEra c)))
-> VerKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
-> VKey 'Genesis (EraCrypto (ShelleyEra c))
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
-> VerKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN (SignKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
 -> VerKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c))))
-> SignKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
-> VerKeyDSIGN (DSIGN (EraCrypto (ShelleyEra c)))
forall a b. (a -> b) -> a -> b
$ CoreNode c -> SignKeyDSIGN (DSIGN c)
forall c. CoreNode c -> SignKeyDSIGN c
cnGenesisKey CoreNode c
cn
          , PParamsUpdate (ShelleyEra c)
forall era. EraPParams era => PParamsUpdate era
SL.emptyPParamsUpdate
            PParamsUpdate (ShelleyEra c)
-> (PParamsUpdate (ShelleyEra c) -> PParamsUpdate (ShelleyEra c))
-> PParamsUpdate (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (StrictMaybe UnitInterval -> Identity (StrictMaybe UnitInterval))
-> PParamsUpdate (ShelleyEra c)
-> Identity (PParamsUpdate (ShelleyEra c))
forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParamsUpdate era) (StrictMaybe UnitInterval)
Lens' (PParamsUpdate (ShelleyEra c)) (StrictMaybe UnitInterval)
SL.ppuDL ((StrictMaybe UnitInterval -> Identity (StrictMaybe UnitInterval))
 -> PParamsUpdate (ShelleyEra c)
 -> Identity (PParamsUpdate (ShelleyEra c)))
-> StrictMaybe UnitInterval
-> PParamsUpdate (ShelleyEra c)
-> PParamsUpdate (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Maybe UnitInterval -> StrictMaybe UnitInterval
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (Maybe UnitInterval -> StrictMaybe UnitInterval)
-> Maybe UnitInterval -> StrictMaybe UnitInterval
forall a b. (a -> b) -> a -> b
$
                           Rational -> Maybe UnitInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational (Rational -> Maybe UnitInterval) -> Rational -> Maybe UnitInterval
forall a b. (a -> b) -> a -> b
$
                           DecentralizationParam -> Rational
decentralizationParamToRational DecentralizationParam
dNew)
            PParamsUpdate (ShelleyEra c)
-> (PParamsUpdate (ShelleyEra c) -> PParamsUpdate (ShelleyEra c))
-> PParamsUpdate (ShelleyEra c)
forall a b. a -> (a -> b) -> b
& (StrictMaybe ProtVer -> Identity (StrictMaybe ProtVer))
-> PParamsUpdate (ShelleyEra c)
-> Identity (PParamsUpdate (ShelleyEra c))
forall era.
(EraPParams era, ProtVerAtMost era 8) =>
Lens' (PParamsUpdate era) (StrictMaybe ProtVer)
Lens' (PParamsUpdate (ShelleyEra c)) (StrictMaybe ProtVer)
SL.ppuProtocolVersionL ((StrictMaybe ProtVer -> Identity (StrictMaybe ProtVer))
 -> PParamsUpdate (ShelleyEra c)
 -> Identity (PParamsUpdate (ShelleyEra c)))
-> StrictMaybe ProtVer
-> PParamsUpdate (ShelleyEra c)
-> PParamsUpdate (ShelleyEra c)
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer -> StrictMaybe ProtVer
forall a. a -> StrictMaybe a
SL.SJust ProtVer
pVer
          )
        | CoreNode c
cn <- [CoreNode c]
coreNodes
        ]

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

initialLovelacePerCoreNode :: Word64
initialLovelacePerCoreNode :: Word64
initialLovelacePerCoreNode = Word64
1000000

mkCredential :: Crypto c => SL.SignKeyDSIGN c -> SL.Credential r c
mkCredential :: forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential = KeyHash r c -> Credential r c
forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
SL.KeyHashObj (KeyHash r c -> Credential r c)
-> (SignKeyDSIGN (DSIGN c) -> KeyHash r c)
-> SignKeyDSIGN (DSIGN c)
-> Credential r c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyDSIGN (DSIGN c) -> KeyHash r c
forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> KeyHash r c
mkKeyHash

mkKeyHash :: Crypto c => SL.SignKeyDSIGN c -> SL.KeyHash r c
mkKeyHash :: forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> KeyHash r c
mkKeyHash = VKey r c -> KeyHash r c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey r c -> KeyHash r c)
-> (SignKeyDSIGN (DSIGN c) -> VKey r c)
-> SignKeyDSIGN (DSIGN c)
-> KeyHash r c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyDSIGN (DSIGN c) -> VKey r c
forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> VKey r c
mkVerKey

mkVerKey :: Crypto c => SL.SignKeyDSIGN c -> SL.VKey r c
mkVerKey :: forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> VKey r c
mkVerKey = VerKeyDSIGN (DSIGN c) -> VKey r c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> VKey r c)
-> (SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c))
-> SignKeyDSIGN (DSIGN c)
-> VKey r c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyDSIGN (DSIGN c) -> VerKeyDSIGN (DSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN

mkKeyPair :: Crypto c => SL.SignKeyDSIGN c -> TL.KeyPair r c
mkKeyPair :: forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> KeyPair r c
mkKeyPair SignKeyDSIGN c
sk = TL.KeyPair { vKey :: VKey r c
vKey = SignKeyDSIGN c -> VKey r c
forall c (r :: KeyRole). Crypto c => SignKeyDSIGN c -> VKey r c
mkVerKey SignKeyDSIGN c
sk, sKey :: SignKeyDSIGN c
sKey = SignKeyDSIGN c
sk }

mkKeyHashVrf :: (HashAlgorithm h, VRFAlgorithm vrf)
             => SignKeyVRF vrf
             -> Hash h (VerKeyVRF vrf)
mkKeyHashVrf :: forall h vrf.
(HashAlgorithm h, VRFAlgorithm vrf) =>
SignKeyVRF vrf -> Hash h (VerKeyVRF vrf)
mkKeyHashVrf = VerKeyVRF vrf -> Hash h (VerKeyVRF vrf)
forall h.
HashAlgorithm h =>
VerKeyVRF vrf -> Hash h (VerKeyVRF vrf)
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
SL.hashVerKeyVRF (VerKeyVRF vrf -> Hash h (VerKeyVRF vrf))
-> (SignKeyVRF vrf -> VerKeyVRF vrf)
-> SignKeyVRF vrf
-> Hash h (VerKeyVRF vrf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyVRF vrf -> VerKeyVRF vrf
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF

networkId :: SL.Network
networkId :: Network
networkId = Network
SL.Testnet

{-------------------------------------------------------------------------------
  Temporary Workaround
-------------------------------------------------------------------------------}

-- | TODO This is a copy-paste-edit of 'mkSetDecentralizationParamTxs'
--
-- Our current plan is to replace all of this infrastructure with the ThreadNet
-- rewrite; so we're minimizing the work and maintenance here for now.
mkMASetDecentralizationParamTxs ::
     forall proto era.
     ( ShelleyBasedEra era
     , SL.AllegraEraTxBody era
     , SL.ShelleyEraTxBody era
     , SL.AtMostEra AlonzoEra era
     )
  => [CoreNode (EraCrypto era)]
  -> ProtVer   -- ^ The proposed protocol version
  -> SlotNo   -- ^ The TTL
  -> DecentralizationParam   -- ^ The new value
  -> [GenTx (ShelleyBlock proto era)]
mkMASetDecentralizationParamTxs :: forall proto era.
(ShelleyBasedEra era, AllegraEraTxBody era, ShelleyEraTxBody era,
 AtMostEra AlonzoEra era) =>
[CoreNode (EraCrypto era)]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock proto era)]
mkMASetDecentralizationParamTxs [CoreNode (EraCrypto era)]
coreNodes ProtVer
pVer SlotNo
ttl DecentralizationParam
dNew =
    (GenTx (ShelleyBlock proto era)
-> [GenTx (ShelleyBlock proto era)]
-> [GenTx (ShelleyBlock proto era)]
forall a. a -> [a] -> [a]
:[]) (GenTx (ShelleyBlock proto era)
 -> [GenTx (ShelleyBlock proto era)])
-> GenTx (ShelleyBlock proto era)
-> [GenTx (ShelleyBlock proto era)]
forall a b. (a -> b) -> a -> b
$
    Tx era -> GenTx (ShelleyBlock proto era)
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx (Tx era -> GenTx (ShelleyBlock proto era))
-> Tx era -> GenTx (ShelleyBlock proto era)
forall a b. (a -> b) -> a -> b
$
    TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
SL.mkBasicTx TxBody era
body Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
SL.witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> TxWits era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
witnesses
  where
    -- The funds touched by this transaction assume it's the first transaction
    -- executed.
    scheduledEpoch :: EpochNo
    scheduledEpoch :: EpochNo
scheduledEpoch = Word64 -> EpochNo
EpochNo Word64
0

    witnesses :: SL.TxWits era
    witnesses :: TxWits era
witnesses = TxWits era
forall era. EraTxWits era => TxWits era
SL.mkBasicTxWits TxWits era -> (TxWits era -> TxWits era) -> TxWits era
forall a b. a -> (a -> b) -> b
& (Set (WitVKey 'Witness (EraCrypto era))
 -> Identity (Set (WitVKey 'Witness (EraCrypto era))))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
SL.addrTxWitsL ((Set (WitVKey 'Witness (EraCrypto era))
  -> Identity (Set (WitVKey 'Witness (EraCrypto era))))
 -> TxWits era -> Identity (TxWits era))
-> Set (WitVKey 'Witness (EraCrypto era))
-> TxWits era
-> TxWits era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness (EraCrypto era))
signatures

    -- Every node signs the transaction body, since it includes a " vote " from
    -- every node.
    signatures :: Set (SL.WitVKey 'SL.Witness (EraCrypto era))
    signatures :: Set (WitVKey 'Witness (EraCrypto era))
signatures =
        SafeHash (EraCrypto era) EraIndependentTxBody
-> [KeyPair Any (EraCrypto era)]
-> Set (WitVKey 'Witness (EraCrypto era))
forall c (kr :: KeyRole).
(Crypto c, DSignable c (Hash (HASH c) EraIndependentTxBody)) =>
SafeHash c EraIndependentTxBody
-> [KeyPair kr c] -> Set (WitVKey 'Witness c)
TL.mkWitnessesVKey
          (TxBody era -> SafeHash (EraCrypto era) EraIndependentTxBody
forall crypto body.
(HashAlgorithm (HASH crypto),
 HashAnnotated body EraIndependentTxBody crypto) =>
body -> SafeHash crypto EraIndependentTxBody
eraIndTxBodyHash' TxBody era
body)
          [ VKey Any (EraCrypto era)
-> SignKeyDSIGN (DSIGN (EraCrypto era))
-> KeyPair Any (EraCrypto era)
forall (kd :: KeyRole) c.
VKey kd c -> SignKeyDSIGN (DSIGN c) -> KeyPair kd c
TL.KeyPair (VerKeyDSIGN (DSIGN (EraCrypto era)) -> VKey Any (EraCrypto era)
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey VerKeyDSIGN (DSIGN (EraCrypto era))
vk) SignKeyDSIGN (DSIGN (EraCrypto era))
sk
          | CoreNode (EraCrypto era)
cn <- [CoreNode (EraCrypto era)]
coreNodes
          , let sk :: SignKeyDSIGN (DSIGN (EraCrypto era))
sk = CoreNode (EraCrypto era) -> SignKeyDSIGN (DSIGN (EraCrypto era))
forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey CoreNode (EraCrypto era)
cn
          , let vk :: VerKeyDSIGN (DSIGN (EraCrypto era))
vk = SignKeyDSIGN (DSIGN (EraCrypto era))
-> VerKeyDSIGN (DSIGN (EraCrypto era))
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (DSIGN (EraCrypto era))
sk
          ]

    -- Nothing but the parameter update and the obligatory touching of an
    -- input.
    body :: SL.TxBody era
    body :: TxBody era
body = TxBody era
forall era. EraTxBody era => TxBody era
SL.mkBasicTxBody
      TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set (TxIn (EraCrypto era))
 -> Identity (Set (TxIn (EraCrypto era))))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
SL.inputsTxBodyL ((Set (TxIn (EraCrypto era))
  -> Identity (Set (TxIn (EraCrypto era))))
 -> TxBody era -> Identity (TxBody era))
-> Set (TxIn (EraCrypto era)) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (TxIn (EraCrypto era))
inputs
      TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
SL.outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxOut era)
outputs
      TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (ValidityInterval -> Identity ValidityInterval)
-> TxBody era -> Identity (TxBody era)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody era) ValidityInterval
SL.vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> TxBody era -> Identity (TxBody era))
-> ValidityInterval -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ValidityInterval
vldt
      TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Update era) -> Identity (StrictMaybe (Update era)))
-> TxBody era -> Identity (TxBody era)
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
Lens' (TxBody era) (StrictMaybe (Update era))
SL.updateTxBodyL ((StrictMaybe (Update era) -> Identity (StrictMaybe (Update era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictMaybe (Update era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (Update era)
update'
      where
        inputs :: Set (TxIn (EraCrypto era))
inputs   = TxIn (EraCrypto era) -> Set (TxIn (EraCrypto era))
forall a. a -> Set a
Set.singleton ((TxIn (EraCrypto era), TxOut era) -> TxIn (EraCrypto era)
forall a b. (a, b) -> a
fst (TxIn (EraCrypto era), TxOut era)
touchCoins)
        outputs :: StrictSeq (TxOut era)
outputs  = TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
Seq.singleton ((TxIn (EraCrypto era), TxOut era) -> TxOut era
forall a b. (a, b) -> b
snd (TxIn (EraCrypto era), TxOut era)
touchCoins)
        vldt :: ValidityInterval
vldt     = SL.ValidityInterval {
                   invalidBefore :: StrictMaybe SlotNo
invalidBefore    = StrictMaybe SlotNo
forall a. StrictMaybe a
SL.SNothing
                 , invalidHereafter :: StrictMaybe SlotNo
invalidHereafter = SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SL.SJust SlotNo
ttl
                 }
        update' :: StrictMaybe (Update era)
update'  = Update era -> StrictMaybe (Update era)
forall a. a -> StrictMaybe a
SL.SJust Update era
update

    -- Every Shelley transaction requires one input.
    --
    -- We use the input of the first node, but we just put it all right back.
    --
    -- ASSUMPTION: This transaction runs in the first slot.
    touchCoins :: (SL.TxIn (EraCrypto era), SL.TxOut era)
    touchCoins :: (TxIn (EraCrypto era), TxOut era)
touchCoins = case [CoreNode (EraCrypto era)]
coreNodes of
        []   -> String -> (TxIn (EraCrypto era), TxOut era)
forall a. HasCallStack => String -> a
error String
"no nodes!"
        CoreNode (EraCrypto era)
cn:[CoreNode (EraCrypto era)]
_ ->
            ( Addr (EraCrypto era) -> TxIn (EraCrypto era)
forall c. Crypto c => Addr c -> TxIn c
SL.initialFundsPseudoTxIn Addr (EraCrypto era)
addr
            , Addr (EraCrypto era) -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
SL.mkBasicTxOut Addr (EraCrypto era)
addr Value era
coin
            )
          where
            addr :: Addr (EraCrypto era)
addr = Network
-> PaymentCredential (EraCrypto era)
-> StakeReference (EraCrypto era)
-> Addr (EraCrypto era)
forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
SL.Addr Network
networkId
                (SignKeyDSIGN (DSIGN (EraCrypto era))
-> PaymentCredential (EraCrypto era)
forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential (CoreNode (EraCrypto era) -> SignKeyDSIGN (DSIGN (EraCrypto era))
forall c. CoreNode c -> SignKeyDSIGN c
cnDelegateKey CoreNode (EraCrypto era)
cn))
                (StakeCredential (EraCrypto era) -> StakeReference (EraCrypto era)
forall c. StakeCredential c -> StakeReference c
SL.StakeRefBase (SignKeyDSIGN (DSIGN (EraCrypto era))
-> StakeCredential (EraCrypto era)
forall c (r :: KeyRole).
Crypto c =>
SignKeyDSIGN c -> Credential r c
mkCredential (CoreNode (EraCrypto era) -> SignKeyDSIGN (DSIGN (EraCrypto era))
forall c. CoreNode c -> SignKeyDSIGN c
cnStakingKey CoreNode (EraCrypto era)
cn)))
            coin :: Value era
coin = Coin -> Value era
forall t s. Inject t s => t -> s
SL.inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
SL.Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
initialLovelacePerCoreNode

    -- One replicant of the parameter update per each node.
    update :: SL.Update era
    update :: Update era
update =
        (ProposedPPUpdates era -> EpochNo -> Update era)
-> EpochNo -> ProposedPPUpdates era -> Update era
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProposedPPUpdates era -> EpochNo -> Update era
forall era. ProposedPPUpdates era -> EpochNo -> Update era
SL.Update EpochNo
scheduledEpoch (ProposedPPUpdates era -> Update era)
-> ProposedPPUpdates era -> Update era
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
SL.ProposedPPUpdates (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
 -> ProposedPPUpdates era)
-> Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$
        [(KeyHash 'Genesis (EraCrypto era), PParamsUpdate era)]
-> Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(KeyHash 'Genesis (EraCrypto era), PParamsUpdate era)]
 -> Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era))
-> [(KeyHash 'Genesis (EraCrypto era), PParamsUpdate era)]
-> Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
forall a b. (a -> b) -> a -> b
$
        [ ( VKey 'Genesis (EraCrypto era) -> KeyHash 'Genesis (EraCrypto era)
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'Genesis (EraCrypto era) -> KeyHash 'Genesis (EraCrypto era))
-> VKey 'Genesis (EraCrypto era)
-> KeyHash 'Genesis (EraCrypto era)
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN (DSIGN (EraCrypto era))
-> VKey 'Genesis (EraCrypto era)
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN (EraCrypto era))
 -> VKey 'Genesis (EraCrypto era))
-> VerKeyDSIGN (DSIGN (EraCrypto era))
-> VKey 'Genesis (EraCrypto era)
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN (DSIGN (EraCrypto era))
-> VerKeyDSIGN (DSIGN (EraCrypto era))
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN (SignKeyDSIGN (DSIGN (EraCrypto era))
 -> VerKeyDSIGN (DSIGN (EraCrypto era)))
-> SignKeyDSIGN (DSIGN (EraCrypto era))
-> VerKeyDSIGN (DSIGN (EraCrypto era))
forall a b. (a -> b) -> a -> b
$ CoreNode (EraCrypto era) -> SignKeyDSIGN (DSIGN (EraCrypto era))
forall c. CoreNode c -> SignKeyDSIGN c
cnGenesisKey CoreNode (EraCrypto era)
cn
          , PParamsUpdate era
forall era. EraPParams era => PParamsUpdate era
SL.emptyPParamsUpdate
            PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe UnitInterval -> Identity (StrictMaybe UnitInterval))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParamsUpdate era) (StrictMaybe UnitInterval)
Lens' (PParamsUpdate era) (StrictMaybe UnitInterval)
SL.ppuDL ((StrictMaybe UnitInterval -> Identity (StrictMaybe UnitInterval))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe UnitInterval
-> PParamsUpdate era
-> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Maybe UnitInterval -> StrictMaybe UnitInterval
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (Maybe UnitInterval -> StrictMaybe UnitInterval)
-> Maybe UnitInterval -> StrictMaybe UnitInterval
forall a b. (a -> b) -> a -> b
$
                           Rational -> Maybe UnitInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational (Rational -> Maybe UnitInterval) -> Rational -> Maybe UnitInterval
forall a b. (a -> b) -> a -> b
$
                           DecentralizationParam -> Rational
decentralizationParamToRational DecentralizationParam
dNew)
            PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe ProtVer -> Identity (StrictMaybe ProtVer))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
(EraPParams era, ProtVerAtMost era 8) =>
Lens' (PParamsUpdate era) (StrictMaybe ProtVer)
Lens' (PParamsUpdate era) (StrictMaybe ProtVer)
SL.ppuProtocolVersionL ((StrictMaybe ProtVer -> Identity (StrictMaybe ProtVer))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe ProtVer -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer -> StrictMaybe ProtVer
forall a. a -> StrictMaybe a
SL.SJust ProtVer
pVer
          )
        | CoreNode (EraCrypto era)
cn <- [CoreNode (EraCrypto era)]
coreNodes
        ]

eraIndTxBodyHash' ::
     forall crypto body.
     ( HashAlgorithm (Cardano.Ledger.Crypto.HASH crypto)
     , HashAnnotated body EraIndependentTxBody crypto
     )
  => body
  -> SafeHash
       crypto
       EraIndependentTxBody
eraIndTxBodyHash' :: forall crypto body.
(HashAlgorithm (HASH crypto),
 HashAnnotated body EraIndependentTxBody crypto) =>
body -> SafeHash crypto EraIndependentTxBody
eraIndTxBodyHash' = SafeHash crypto EraIndependentTxBody
-> SafeHash crypto EraIndependentTxBody
forall a b. Coercible a b => a -> b
coerce (SafeHash crypto EraIndependentTxBody
 -> SafeHash crypto EraIndependentTxBody)
-> (body -> SafeHash crypto EraIndependentTxBody)
-> body
-> SafeHash crypto EraIndependentTxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. body -> SafeHash crypto EraIndependentTxBody
forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated