{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.ThreadNet.TxGen.Cardano (CardanoTxGenExtra (..)) where

import qualified Cardano.Chain.Common as Byron
import Cardano.Chain.Genesis (GeneratedSecrets (..))
import Cardano.Crypto (toVerification)
import qualified Cardano.Crypto.DSIGN as DSIGN
import qualified Cardano.Crypto.Signing as Byron
import qualified Cardano.Crypto.VRF as VRF
import qualified Cardano.Ledger.Address as SL (BootstrapAddress (..))
import qualified Cardano.Ledger.Hashes as SL
import Cardano.Ledger.Keys (DSIGN)
import qualified Cardano.Ledger.Keys.Bootstrap as SL (makeBootstrapWitness)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Core as SL
import Cardano.Ledger.Val ((<->))
import Cardano.Protocol.Crypto (VRF)
import Control.Exception (assert)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (maybeToList)
import Data.SOP.Strict
import Data.SOP.Telescope as Tele
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Lens.Micro
import Ouroboros.Consensus.Block (SlotNo (..))
import Ouroboros.Consensus.Cardano
import Ouroboros.Consensus.Cardano.Block
  ( CardanoEras
  , GenTx (..)
  , ShelleyEra
  )
import Ouroboros.Consensus.Cardano.Node (CardanoHardForkConstraints)
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Combinator.Ledger
  ( getFlipTickedLedgerState
  , tickedHardForkLedgerStatePerEra
  )
import Ouroboros.Consensus.HardFork.Combinator.State.Types
  ( currentState
  , getHardForkState
  )
import Ouroboros.Consensus.Ledger.Basics
  ( ComputeLedgerEvents (..)
  , LedgerConfig
  , LedgerState
  , TickedLedgerState
  , applyChainTick
  )
import Ouroboros.Consensus.Ledger.Tables (ValuesMK)
import Ouroboros.Consensus.Ledger.Tables.Utils
  ( applyDiffs
  , forgetLedgerTables
  )
import Ouroboros.Consensus.NodeId (CoreNodeId (..))
import Ouroboros.Consensus.Protocol.TPraos (TPraos)
import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, mkShelleyTx)
import Ouroboros.Consensus.Shelley.Ledger.Ledger
  ( tickedShelleyLedgerState
  )
import qualified Test.Cardano.Ledger.Core.KeyPair as TL (mkWitnessVKey)
import qualified Test.ThreadNet.Infra.Shelley as Shelley
import Test.ThreadNet.TxGen

data CardanoTxGenExtra c = CardanoTxGenExtra
  { forall c. CardanoTxGenExtra c -> GeneratedSecrets
ctgeByronGenesisKeys :: GeneratedSecrets
  , forall c. CardanoTxGenExtra c -> NetworkMagic
ctgeNetworkMagic :: Byron.NetworkMagic
  , forall c. CardanoTxGenExtra c -> [CoreNode c]
ctgeShelleyCoreNodes :: [Shelley.CoreNode c]
  }

instance CardanoHardForkConstraints c => TxGen (CardanoBlock c) where
  type TxGenExtra (CardanoBlock c) = CardanoTxGenExtra c

  -- TODO also generate " typical " Byron and Shelley transactions
  testGenTxs :: CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig (CardanoBlock c)
-> TxGenExtra (CardanoBlock c)
-> LedgerState (CardanoBlock c) ValuesMK
-> Gen [GenTx (CardanoBlock c)]
testGenTxs (CoreNodeId Word64
i) NumCoreNodes
_ncn SlotNo
curSlot TopLevelConfig (CardanoBlock c)
cfg TxGenExtra (CardanoBlock c)
extra LedgerState (CardanoBlock c) ValuesMK
ls =
    [GenTx (CardanoBlock c)] -> Gen [GenTx (CardanoBlock c)]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenTx (CardanoBlock c)] -> Gen [GenTx (CardanoBlock c)])
-> [GenTx (CardanoBlock c)] -> Gen [GenTx (CardanoBlock c)]
forall a b. (a -> b) -> a -> b
$ Maybe (GenTx (CardanoBlock c)) -> [GenTx (CardanoBlock c)]
forall a. Maybe a -> [a]
maybeToList (Maybe (GenTx (CardanoBlock c)) -> [GenTx (CardanoBlock c)])
-> Maybe (GenTx (CardanoBlock c)) -> [GenTx (CardanoBlock c)]
forall a b. (a -> b) -> a -> b
$ MigrationInfo c
-> SlotNo
-> LedgerConfig (CardanoBlock c)
-> LedgerState (CardanoBlock c) ValuesMK
-> Maybe (GenTx (CardanoBlock c))
forall c.
CardanoHardForkConstraints c =>
MigrationInfo c
-> SlotNo
-> LedgerConfig (CardanoBlock c)
-> LedgerState (CardanoBlock c) ValuesMK
-> Maybe (GenTx (CardanoBlock c))
migrateUTxO MigrationInfo c
migrationInfo SlotNo
curSlot LedgerConfig (CardanoBlock c)
lcfg LedgerState (CardanoBlock c) ValuesMK
ls
   where
    lcfg :: LedgerConfig (CardanoBlock c)
lcfg = TopLevelConfig (CardanoBlock c) -> LedgerConfig (CardanoBlock c)
forall blk. TopLevelConfig blk -> LedgerConfig blk
topLevelConfigLedger TopLevelConfig (CardanoBlock c)
cfg

    CardanoTxGenExtra
      { GeneratedSecrets
ctgeByronGenesisKeys :: forall c. CardanoTxGenExtra c -> GeneratedSecrets
ctgeByronGenesisKeys :: GeneratedSecrets
ctgeByronGenesisKeys
      , NetworkMagic
ctgeNetworkMagic :: forall c. CardanoTxGenExtra c -> NetworkMagic
ctgeNetworkMagic :: NetworkMagic
ctgeNetworkMagic
      , [CoreNode c]
ctgeShelleyCoreNodes :: forall c. CardanoTxGenExtra c -> [CoreNode c]
ctgeShelleyCoreNodes :: [CoreNode c]
ctgeShelleyCoreNodes
      } = TxGenExtra (CardanoBlock c)
extra

    GeneratedSecrets
      { [SigningKey]
gsRichSecrets :: [SigningKey]
gsRichSecrets :: GeneratedSecrets -> [SigningKey]
gsRichSecrets
      } = GeneratedSecrets
ctgeByronGenesisKeys

    migrationInfo :: MigrationInfo c
migrationInfo =
      MigrationInfo
        { byronMagic :: NetworkMagic
byronMagic = NetworkMagic
ctgeNetworkMagic
        , SigningKey
byronSK :: SigningKey
byronSK :: SigningKey
byronSK
        , SignKeyDSIGN DSIGN
paymentSK :: SignKeyDSIGN DSIGN
paymentSK :: SignKeyDSIGN DSIGN
paymentSK
        , SignKeyDSIGN DSIGN
poolSK :: SignKeyDSIGN DSIGN
poolSK :: SignKeyDSIGN DSIGN
poolSK
        , SignKeyDSIGN DSIGN
stakingSK :: SignKeyDSIGN DSIGN
stakingSK :: SignKeyDSIGN DSIGN
stakingSK
        , SignKeyVRF (VRF c)
vrfSK :: SignKeyVRF (VRF c)
vrfSK :: SignKeyVRF (VRF c)
vrfSK
        }

    byronSK :: Byron.SigningKey
    byronSK :: SigningKey
byronSK = [SigningKey]
gsRichSecrets [SigningKey] -> Int -> SigningKey
forall a. HasCallStack => [a] -> Int -> a
!! Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i

    Shelley.CoreNode
      { cnDelegateKey :: forall c. CoreNode c -> SignKeyDSIGN DSIGN
Shelley.cnDelegateKey = SignKeyDSIGN DSIGN
paymentSK
      , cnStakingKey :: forall c. CoreNode c -> SignKeyDSIGN DSIGN
Shelley.cnStakingKey = SignKeyDSIGN DSIGN
stakingSK
      , cnVRF :: forall c. CoreNode c -> SignKeyVRF (VRF c)
Shelley.cnVRF = SignKeyVRF (VRF c)
vrfSK
      } = [CoreNode c]
ctgeShelleyCoreNodes [CoreNode c] -> Int -> CoreNode c
forall a. HasCallStack => [a] -> Int -> a
!! Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i

    -- Reuse the payment key as the pool key, since it's an individual
    -- stake pool and the namespaces are separate.
    poolSK :: DSIGN.SignKeyDSIGN DSIGN
    poolSK :: SignKeyDSIGN DSIGN
poolSK = SignKeyDSIGN DSIGN
paymentSK

-- | See 'migrateUTxO'
data MigrationInfo c = MigrationInfo
  { forall c. MigrationInfo c -> NetworkMagic
byronMagic :: Byron.NetworkMagic
  -- ^ Needed for creating a Byron address.
  , forall c. MigrationInfo c -> SigningKey
byronSK :: Byron.SigningKey
  -- ^ The core node's Byron secret.
  , forall c. MigrationInfo c -> SignKeyDSIGN DSIGN
paymentSK :: DSIGN.SignKeyDSIGN DSIGN
  , forall c. MigrationInfo c -> SignKeyDSIGN DSIGN
poolSK :: DSIGN.SignKeyDSIGN DSIGN
  , forall c. MigrationInfo c -> SignKeyDSIGN DSIGN
stakingSK :: DSIGN.SignKeyDSIGN DSIGN
  , forall c. MigrationInfo c -> SignKeyVRF (VRF c)
vrfSK :: VRF.SignKeyVRF (VRF c)
  -- ^ To be re-used by the individual pool.
  }

-- | Convert a core node's utxo from Byron to an active Shelley stake pool.
--
-- Returns a transaction that registers a staking key, registers an individual
-- stake pool, delegates that stake key to that stake pool, and transfers all
-- utxo from the Byron 'byronAddr' to the Shelley address corresponding to the
-- pair of 'paymentSK' and 'stakingSK'.
--
-- It returns 'Nothing' if the core node does not have any utxo in its
-- 'byronAddr' (eg if this transaction has already been applied).
migrateUTxO ::
  forall c.
  CardanoHardForkConstraints c =>
  MigrationInfo c ->
  SlotNo ->
  LedgerConfig (CardanoBlock c) ->
  LedgerState (CardanoBlock c) ValuesMK ->
  Maybe (GenTx (CardanoBlock c))
migrateUTxO :: forall c.
CardanoHardForkConstraints c =>
MigrationInfo c
-> SlotNo
-> LedgerConfig (CardanoBlock c)
-> LedgerState (CardanoBlock c) ValuesMK
-> Maybe (GenTx (CardanoBlock c))
migrateUTxO MigrationInfo c
migrationInfo SlotNo
curSlot LedgerConfig (CardanoBlock c)
lcfg LedgerState (CardanoBlock c) ValuesMK
lst
  | Just UTxO ShelleyEra
utxo <- Maybe (UTxO ShelleyEra)
mbUTxO =
      let picked :: Map SL.TxIn (SL.TxOut ShelleyEra)
          picked :: Map TxIn (TxOut ShelleyEra)
picked = (TxOut ShelleyEra -> Bool)
-> Map TxIn (TxOut ShelleyEra) -> Map TxIn (TxOut ShelleyEra)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter TxOut ShelleyEra -> Bool
ShelleyTxOut ShelleyEra -> Bool
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Era era, Val (Value era)) =>
ShelleyTxOut era -> Bool
pick (Map TxIn (TxOut ShelleyEra) -> Map TxIn (TxOut ShelleyEra))
-> Map TxIn (TxOut ShelleyEra) -> Map TxIn (TxOut ShelleyEra)
forall a b. (a -> b) -> a -> b
$ UTxO ShelleyEra -> Map TxIn (TxOut ShelleyEra)
forall era. UTxO era -> Map TxIn (TxOut era)
SL.unUTxO UTxO ShelleyEra
utxo
           where
            pick :: ShelleyTxOut era -> Bool
pick (SL.ShelleyTxOut Addr
addr Value era
_) =
              Addr
addr Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== BootstrapAddress -> Addr
SL.AddrBootstrap (Address -> BootstrapAddress
SL.BootstrapAddress Address
byronAddr)

          -- Total held by 'byronAddr'
          pickedCoin :: SL.Coin
          pickedCoin :: Coin
pickedCoin = (ShelleyTxOut ShelleyEra -> Coin)
-> Map TxIn (ShelleyTxOut ShelleyEra) -> Coin
forall m a. Monoid m => (a -> m) -> Map TxIn a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(SL.ShelleyTxOut Addr
_ Value ShelleyEra
coin) -> Value ShelleyEra
Coin
coin) Map TxIn (TxOut ShelleyEra)
Map TxIn (ShelleyTxOut ShelleyEra)
picked

          -- NOTE: The Cardano ThreadNet tests use the
          -- ouroboros-consensus-shelley-test infra's genesis config, which sets
          -- relevant protocol params to 0.
          fee, deposits, spentCoin :: SL.Coin
          fee :: Coin
fee = Integer -> Coin
SL.Coin Integer
0
          deposits :: Coin
deposits = Integer -> Coin
SL.Coin Integer
0
          spentCoin :: Coin
spentCoin = Coin
deposits Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
fee

          unspentCoin :: SL.Coin
          unspentCoin :: Coin
unspentCoin =
            Bool -> Coin -> Coin
forall a. HasCallStack => Bool -> a -> a
assert (Coin
pickedCoin Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
spentCoin) (Coin -> Coin) -> Coin -> Coin
forall a b. (a -> b) -> a -> b
$
              Coin
pickedCoin Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
spentCoin

          body :: SL.TxBody ShelleyEra
          body :: TxBody ShelleyEra
body =
            TxBody ShelleyEra
forall era. EraTxBody era => TxBody era
SL.mkBasicTxBody
              TxBody ShelleyEra
-> (TxBody ShelleyEra -> TxBody ShelleyEra) -> TxBody ShelleyEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert ShelleyEra)
 -> Identity (StrictSeq (TxCert ShelleyEra)))
-> TxBody ShelleyEra -> Identity (TxBody ShelleyEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody ShelleyEra) (StrictSeq (TxCert ShelleyEra))
SL.certsTxBodyL
                ((StrictSeq (TxCert ShelleyEra)
  -> Identity (StrictSeq (TxCert ShelleyEra)))
 -> TxBody ShelleyEra -> Identity (TxBody ShelleyEra))
-> StrictSeq (TxCert ShelleyEra)
-> TxBody ShelleyEra
-> TxBody ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert ShelleyEra] -> StrictSeq (TxCert ShelleyEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
                  [ StakeCredential -> TxCert ShelleyEra
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
SL.RegTxCert (StakeCredential -> TxCert ShelleyEra)
-> StakeCredential -> TxCert ShelleyEra
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN DSIGN -> StakeCredential
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> Credential r
Shelley.mkCredential SignKeyDSIGN DSIGN
stakingSK
                  , PoolParams -> TxCert ShelleyEra
forall era. EraTxCert era => PoolParams -> TxCert era
SL.RegPoolTxCert (PoolParams -> TxCert ShelleyEra)
-> PoolParams -> TxCert ShelleyEra
forall a b. (a -> b) -> a -> b
$ Coin -> PoolParams
poolParams Coin
unspentCoin
                  , StakeCredential -> KeyHash 'StakePool -> TxCert ShelleyEra
forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash 'StakePool -> TxCert era
SL.DelegStakeTxCert
                      (SignKeyDSIGN DSIGN -> StakeCredential
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> Credential r
Shelley.mkCredential SignKeyDSIGN DSIGN
stakingSK)
                      (SignKeyDSIGN DSIGN -> KeyHash 'StakePool
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> KeyHash r
Shelley.mkKeyHash SignKeyDSIGN DSIGN
poolSK)
                  ]
              TxBody ShelleyEra
-> (TxBody ShelleyEra -> TxBody ShelleyEra) -> TxBody ShelleyEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody ShelleyEra -> Identity (TxBody ShelleyEra)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ShelleyEra) (Set TxIn)
SL.inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody ShelleyEra -> Identity (TxBody ShelleyEra))
-> Set TxIn -> TxBody ShelleyEra -> TxBody ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map TxIn (ShelleyTxOut ShelleyEra) -> Set TxIn
forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut ShelleyEra)
Map TxIn (ShelleyTxOut ShelleyEra)
picked
              TxBody ShelleyEra
-> (TxBody ShelleyEra -> TxBody ShelleyEra) -> TxBody ShelleyEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut ShelleyEra)
 -> Identity (StrictSeq (TxOut ShelleyEra)))
-> TxBody ShelleyEra -> Identity (TxBody ShelleyEra)
(StrictSeq (TxOut ShelleyEra)
 -> Identity (StrictSeq (ShelleyTxOut ShelleyEra)))
-> TxBody ShelleyEra -> Identity (TxBody ShelleyEra)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ShelleyEra) (StrictSeq (TxOut ShelleyEra))
SL.outputsTxBodyL
                ((StrictSeq (TxOut ShelleyEra)
  -> Identity (StrictSeq (ShelleyTxOut ShelleyEra)))
 -> TxBody ShelleyEra -> Identity (TxBody ShelleyEra))
-> StrictSeq (ShelleyTxOut ShelleyEra)
-> TxBody ShelleyEra
-> TxBody ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ShelleyTxOut ShelleyEra -> StrictSeq (ShelleyTxOut ShelleyEra)
forall a. a -> StrictSeq a
StrictSeq.singleton (Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
SL.ShelleyTxOut Addr
shelleyAddr Value ShelleyEra
Coin
unspentCoin)
              TxBody ShelleyEra
-> (TxBody ShelleyEra -> TxBody ShelleyEra) -> TxBody ShelleyEra
forall a b. a -> (a -> b) -> b
& (SlotNo -> Identity SlotNo)
-> TxBody ShelleyEra -> Identity (TxBody ShelleyEra)
forall era.
(ShelleyEraTxBody era, ExactEra ShelleyEra era) =>
Lens' (TxBody era) SlotNo
Lens' (TxBody ShelleyEra) SlotNo
SL.ttlTxBodyL ((SlotNo -> Identity SlotNo)
 -> TxBody ShelleyEra -> Identity (TxBody ShelleyEra))
-> SlotNo -> TxBody ShelleyEra -> TxBody ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64 -> SlotNo
SlotNo Word64
forall a. Bounded a => a
maxBound
              TxBody ShelleyEra
-> (TxBody ShelleyEra -> ShelleyTxBody ShelleyEra)
-> ShelleyTxBody ShelleyEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody ShelleyEra -> Identity (TxBody ShelleyEra)
(Coin -> Identity Coin)
-> TxBody ShelleyEra -> Identity (ShelleyTxBody ShelleyEra)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody ShelleyEra) Coin
SL.feeTxBodyL ((Coin -> Identity Coin)
 -> TxBody ShelleyEra -> Identity (ShelleyTxBody ShelleyEra))
-> Coin -> TxBody ShelleyEra -> ShelleyTxBody ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee

          bodyHash :: SL.SafeHash SL.EraIndependentTxBody
          bodyHash :: SafeHash EraIndependentTxBody
bodyHash = ShelleyTxBody ShelleyEra -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
SL.hashAnnotated TxBody ShelleyEra
ShelleyTxBody ShelleyEra
body

          -- Witness the use of bootstrap address's utxo.
          byronWit :: SL.BootstrapWitness
          byronWit :: BootstrapWitness
byronWit =
            Hash HASH EraIndependentTxBody
-> SigningKey -> Attributes AddrAttributes -> BootstrapWitness
SL.makeBootstrapWitness (SafeHash EraIndependentTxBody -> Hash HASH EraIndependentTxBody
forall i. SafeHash i -> Hash HASH i
SL.extractHash SafeHash EraIndependentTxBody
bodyHash) SigningKey
byronSK (Attributes AddrAttributes -> BootstrapWitness)
-> Attributes AddrAttributes -> BootstrapWitness
forall a b. (a -> b) -> a -> b
$
              Address -> Attributes AddrAttributes
Byron.addrAttributes Address
byronAddr

          -- Witness the stake delegation.
          delegWit :: SL.WitVKey 'SL.Witness
          delegWit :: WitVKey 'Witness
delegWit =
            SafeHash EraIndependentTxBody -> KeyPair Any -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
TL.mkWitnessVKey
              SafeHash EraIndependentTxBody
bodyHash
              (SignKeyDSIGN DSIGN -> KeyPair Any
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> KeyPair r
Shelley.mkKeyPair SignKeyDSIGN DSIGN
stakingSK)

          -- Witness the pool registration.
          poolWit :: SL.WitVKey 'SL.Witness
          poolWit :: WitVKey 'Witness
poolWit =
            SafeHash EraIndependentTxBody -> KeyPair Any -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
TL.mkWitnessVKey
              SafeHash EraIndependentTxBody
bodyHash
              (SignKeyDSIGN DSIGN -> KeyPair Any
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> KeyPair r
Shelley.mkKeyPair SignKeyDSIGN DSIGN
poolSK)
       in if Map TxIn (ShelleyTxOut ShelleyEra) -> Bool
forall k a. Map k a -> Bool
Map.null Map TxIn (TxOut ShelleyEra)
Map TxIn (ShelleyTxOut ShelleyEra)
picked
            then Maybe (GenTx (CardanoBlock c))
forall a. Maybe a
Nothing
            else
              (GenTx (CardanoBlock c) -> Maybe (GenTx (CardanoBlock c))
forall a. a -> Maybe a
Just (GenTx (CardanoBlock c) -> Maybe (GenTx (CardanoBlock c)))
-> (ShelleyTx ShelleyEra -> GenTx (CardanoBlock c))
-> ShelleyTx ShelleyEra
-> Maybe (GenTx (CardanoBlock c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (ShelleyBlock (TPraos c) ShelleyEra)
-> GenTx (CardanoBlock c)
forall c.
GenTx (ShelleyBlock (TPraos c) ShelleyEra) -> CardanoGenTx c
GenTxShelley (GenTx (ShelleyBlock (TPraos c) ShelleyEra)
 -> GenTx (CardanoBlock c))
-> (ShelleyTx ShelleyEra
    -> GenTx (ShelleyBlock (TPraos c) ShelleyEra))
-> ShelleyTx ShelleyEra
-> GenTx (CardanoBlock c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx ShelleyEra -> GenTx (ShelleyBlock (TPraos c) ShelleyEra)
ShelleyTx ShelleyEra -> GenTx (ShelleyBlock (TPraos c) ShelleyEra)
forall era proto.
ShelleyBasedEra era =>
Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx) (ShelleyTx ShelleyEra -> Maybe (GenTx (CardanoBlock c)))
-> ShelleyTx ShelleyEra -> Maybe (GenTx (CardanoBlock c))
forall a b. (a -> b) -> a -> b
$
                SL.ShelleyTx
                  { body :: TxBody ShelleyEra
SL.body = TxBody ShelleyEra
body
                  , auxiliaryData :: StrictMaybe (TxAuxData ShelleyEra)
SL.auxiliaryData = StrictMaybe (TxAuxData ShelleyEra)
StrictMaybe (ShelleyTxAuxData ShelleyEra)
forall a. StrictMaybe a
SL.SNothing
                  , wits :: TxWits ShelleyEra
SL.wits =
                      TxWits ShelleyEra
forall era. EraTxWits era => TxWits era
SL.mkBasicTxWits
                        TxWits ShelleyEra
-> (TxWits ShelleyEra -> TxWits ShelleyEra) -> TxWits ShelleyEra
forall a b. a -> (a -> b) -> b
& (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits ShelleyEra -> Identity (TxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits ShelleyEra) (Set (WitVKey 'Witness))
SL.addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> TxWits ShelleyEra -> Identity (TxWits ShelleyEra))
-> Set (WitVKey 'Witness) -> TxWits ShelleyEra -> TxWits ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [WitVKey 'Witness] -> Set (WitVKey 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList [WitVKey 'Witness
delegWit, WitVKey 'Witness
poolWit]
                        TxWits ShelleyEra
-> (TxWits ShelleyEra -> ShelleyTxWits ShelleyEra)
-> ShelleyTxWits ShelleyEra
forall a b. a -> (a -> b) -> b
& (Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> TxWits ShelleyEra -> Identity (TxWits ShelleyEra)
(Set BootstrapWitness -> Identity (Set BootstrapWitness))
-> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set BootstrapWitness)
Lens' (TxWits ShelleyEra) (Set BootstrapWitness)
SL.bootAddrTxWitsL ((Set BootstrapWitness -> Identity (Set BootstrapWitness))
 -> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
-> Set BootstrapWitness
-> TxWits ShelleyEra
-> ShelleyTxWits ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BootstrapWitness -> Set BootstrapWitness
forall a. a -> Set a
Set.singleton BootstrapWitness
byronWit
                  }
  | Bool
otherwise = Maybe (GenTx (CardanoBlock c))
forall a. Maybe a
Nothing
 where
  mbUTxO :: Maybe (SL.UTxO ShelleyEra)
  mbUTxO :: Maybe (UTxO ShelleyEra)
mbUTxO =
    (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK
 -> UTxO ShelleyEra)
-> Maybe
     (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK)
-> Maybe (UTxO ShelleyEra)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK
-> UTxO ShelleyEra
forall proto era (mk :: MapKind).
TickedLedgerState (ShelleyBlock proto era) mk -> UTxO era
getUTxOShelley
      (Maybe
   (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK)
 -> Maybe (UTxO ShelleyEra))
-> (LedgerState (CardanoBlock c) ValuesMK
    -> Maybe
         (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK))
-> LedgerState (CardanoBlock c) ValuesMK
-> Maybe (UTxO ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (CardanoBlock c) ValuesMK
-> Maybe
     (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK)
forall c (mk :: MapKind).
TickedLedgerState (CardanoBlock c) mk
-> Maybe
     (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk)
ejectShelleyTickedLedgerState
      (TickedLedgerState (CardanoBlock c) ValuesMK
 -> Maybe
      (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK))
-> (LedgerState (CardanoBlock c) ValuesMK
    -> TickedLedgerState (CardanoBlock c) ValuesMK)
-> LedgerState (CardanoBlock c) ValuesMK
-> Maybe
     (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (CardanoBlock c) ValuesMK
-> Ticked (LedgerState (CardanoBlock c)) DiffMK
-> TickedLedgerState (CardanoBlock c) ValuesMK
forall (l :: MapKind -> *) (l' :: MapKind -> *).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs LedgerState (CardanoBlock c) ValuesMK
lst
      (Ticked (LedgerState (CardanoBlock c)) DiffMK
 -> TickedLedgerState (CardanoBlock c) ValuesMK)
-> (LedgerState (CardanoBlock c) ValuesMK
    -> Ticked (LedgerState (CardanoBlock c)) DiffMK)
-> LedgerState (CardanoBlock c) ValuesMK
-> TickedLedgerState (CardanoBlock c) ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComputeLedgerEvents
-> LedgerConfig (CardanoBlock c)
-> SlotNo
-> LedgerState (CardanoBlock c) EmptyMK
-> Ticked (LedgerState (CardanoBlock c)) DiffMK
forall (l :: MapKind -> *).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked l DiffMK
applyChainTick ComputeLedgerEvents
OmitLedgerEvents LedgerConfig (CardanoBlock c)
lcfg SlotNo
curSlot
      (LedgerState (CardanoBlock c) EmptyMK
 -> Ticked (LedgerState (CardanoBlock c)) DiffMK)
-> (LedgerState (CardanoBlock c) ValuesMK
    -> LedgerState (CardanoBlock c) EmptyMK)
-> LedgerState (CardanoBlock c) ValuesMK
-> Ticked (LedgerState (CardanoBlock c)) DiffMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (CardanoBlock c) ValuesMK
-> LedgerState (CardanoBlock c) EmptyMK
forall (l :: MapKind -> *) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables
      (LedgerState (CardanoBlock c) ValuesMK -> Maybe (UTxO ShelleyEra))
-> LedgerState (CardanoBlock c) ValuesMK -> Maybe (UTxO ShelleyEra)
forall a b. (a -> b) -> a -> b
$ LedgerState (CardanoBlock c) ValuesMK
lst

  MigrationInfo
    { NetworkMagic
byronMagic :: forall c. MigrationInfo c -> NetworkMagic
byronMagic :: NetworkMagic
byronMagic
    , SigningKey
byronSK :: forall c. MigrationInfo c -> SigningKey
byronSK :: SigningKey
byronSK
    , SignKeyDSIGN DSIGN
paymentSK :: forall c. MigrationInfo c -> SignKeyDSIGN DSIGN
paymentSK :: SignKeyDSIGN DSIGN
paymentSK
    , SignKeyDSIGN DSIGN
poolSK :: forall c. MigrationInfo c -> SignKeyDSIGN DSIGN
poolSK :: SignKeyDSIGN DSIGN
poolSK
    , SignKeyDSIGN DSIGN
stakingSK :: forall c. MigrationInfo c -> SignKeyDSIGN DSIGN
stakingSK :: SignKeyDSIGN DSIGN
stakingSK
    , SignKeyVRF (VRF c)
vrfSK :: forall c. MigrationInfo c -> SignKeyVRF (VRF c)
vrfSK :: SignKeyVRF (VRF c)
vrfSK
    } = MigrationInfo c
migrationInfo

  byronAddr :: Byron.Address
  byronAddr :: Address
byronAddr =
    NetworkMagic -> VerificationKey -> Address
Byron.makeVerKeyAddress NetworkMagic
byronMagic (VerificationKey -> Address) -> VerificationKey -> Address
forall a b. (a -> b) -> a -> b
$ SigningKey -> VerificationKey
toVerification SigningKey
byronSK

  -- We use a base reference for the stake so that we can refer to it in the
  -- same tx that registers it.
  shelleyAddr :: SL.Addr
  shelleyAddr :: Addr
shelleyAddr =
    Network -> PaymentCredential -> StakeReference -> Addr
SL.Addr
      Network
Shelley.networkId
      (SignKeyDSIGN DSIGN -> PaymentCredential
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> Credential r
Shelley.mkCredential SignKeyDSIGN DSIGN
paymentSK)
      (StakeCredential -> StakeReference
SL.StakeRefBase (StakeCredential -> StakeReference)
-> StakeCredential -> StakeReference
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN DSIGN -> StakeCredential
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> Credential r
Shelley.mkCredential SignKeyDSIGN DSIGN
stakingSK)

  -- A simplistic individual pool
  poolParams :: SL.Coin -> SL.PoolParams
  poolParams :: Coin -> PoolParams
poolParams Coin
pledge =
    SL.PoolParams
      { ppCost :: Coin
SL.ppCost = Integer -> Coin
SL.Coin Integer
1
      , ppMetadata :: StrictMaybe PoolMetadata
SL.ppMetadata = StrictMaybe PoolMetadata
forall a. StrictMaybe a
SL.SNothing
      , ppMargin :: UnitInterval
SL.ppMargin = UnitInterval
forall a. Bounded a => a
minBound
      , ppOwners :: Set (KeyHash 'Staking)
SL.ppOwners = KeyHash 'Staking -> Set (KeyHash 'Staking)
forall a. a -> Set a
Set.singleton (KeyHash 'Staking -> Set (KeyHash 'Staking))
-> KeyHash 'Staking -> Set (KeyHash 'Staking)
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN DSIGN -> KeyHash 'Staking
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> KeyHash r
Shelley.mkKeyHash SignKeyDSIGN DSIGN
poolSK
      , ppPledge :: Coin
SL.ppPledge = Coin
pledge
      , ppId :: KeyHash 'StakePool
SL.ppId = SignKeyDSIGN DSIGN -> KeyHash 'StakePool
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> KeyHash r
Shelley.mkKeyHash SignKeyDSIGN DSIGN
poolSK
      , ppRewardAccount :: RewardAccount
SL.ppRewardAccount =
          Network -> StakeCredential -> RewardAccount
SL.RewardAccount Network
Shelley.networkId (StakeCredential -> RewardAccount)
-> StakeCredential -> RewardAccount
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN DSIGN -> StakeCredential
forall (r :: KeyRole). SignKeyDSIGN DSIGN -> Credential r
Shelley.mkCredential SignKeyDSIGN DSIGN
poolSK
      , ppRelays :: StrictSeq StakePoolRelay
SL.ppRelays = StrictSeq StakePoolRelay
forall a. StrictSeq a
StrictSeq.empty
      , ppVrf :: VRFVerKeyHash 'StakePoolVRF
SL.ppVrf = forall c (r :: KeyRoleVRF).
Crypto c =>
SignKeyVRF (VRF c) -> VRFVerKeyHash r
Shelley.mkKeyHashVrf @c SignKeyVRF (VRF c)
vrfSK
      }

-----

ejectShelleyNS ::
  NS f (CardanoEras c) ->
  Maybe (f (ShelleyBlock (TPraos c) ShelleyEra))
ejectShelleyNS :: forall (f :: * -> *) c.
NS f (CardanoEras c)
-> Maybe (f (ShelleyBlock (TPraos c) ShelleyEra))
ejectShelleyNS = \case
  S (Z f x
x) -> f (ShelleyBlock (TPraos c) ShelleyEra)
-> Maybe (f (ShelleyBlock (TPraos c) ShelleyEra))
forall a. a -> Maybe a
Just f x
f (ShelleyBlock (TPraos c) ShelleyEra)
x
  NS f (CardanoEras c)
_ -> Maybe (f (ShelleyBlock (TPraos c) ShelleyEra))
forall a. Maybe a
Nothing

getUTxOShelley ::
  TickedLedgerState (ShelleyBlock proto era) mk ->
  SL.UTxO era
getUTxOShelley :: forall proto era (mk :: MapKind).
TickedLedgerState (ShelleyBlock proto era) mk -> UTxO era
getUTxOShelley TickedLedgerState (ShelleyBlock proto era) mk
tls =
  UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
SL.utxosUtxo (UTxOState era -> UTxO era) -> UTxOState era -> UTxO era
forall a b. (a -> b) -> a -> b
$
    LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
SL.lsUTxOState (LedgerState era -> UTxOState era)
-> LedgerState era -> UTxOState era
forall a b. (a -> b) -> a -> b
$
      EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
SL.esLState (EpochState era -> LedgerState era)
-> EpochState era -> LedgerState era
forall a b. (a -> b) -> a -> b
$
        NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
SL.nesEs (NewEpochState era -> EpochState era)
-> NewEpochState era -> EpochState era
forall a b. (a -> b) -> a -> b
$
          TickedLedgerState (ShelleyBlock proto era) mk -> NewEpochState era
forall proto era (mk :: MapKind).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState TickedLedgerState (ShelleyBlock proto era) mk
tls

ejectShelleyTickedLedgerState ::
  TickedLedgerState (CardanoBlock c) mk ->
  Maybe (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk)
ejectShelleyTickedLedgerState :: forall c (mk :: MapKind).
TickedLedgerState (CardanoBlock c) mk
-> Maybe
     (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk)
ejectShelleyTickedLedgerState TickedLedgerState (CardanoBlock c) mk
ls =
  (Current
   (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra)
 -> TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk)
-> Maybe
     (Current
        (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra))
-> Maybe
     (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FlipTickedLedgerState mk (ShelleyBlock (TPraos c) ShelleyEra)
-> TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState (FlipTickedLedgerState mk (ShelleyBlock (TPraos c) ShelleyEra)
 -> TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk)
-> (Current
      (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra)
    -> FlipTickedLedgerState mk (ShelleyBlock (TPraos c) ShelleyEra))
-> Current
     (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra)
-> TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Current
  (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra)
-> FlipTickedLedgerState mk (ShelleyBlock (TPraos c) ShelleyEra)
forall (f :: * -> *) blk. Current f blk -> f blk
currentState) (Maybe
   (Current
      (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra))
 -> Maybe
      (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk))
-> Maybe
     (Current
        (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra))
-> Maybe
     (TickedLedgerState (ShelleyBlock (TPraos c) ShelleyEra) mk)
forall a b. (a -> b) -> a -> b
$
    NS (Current (FlipTickedLedgerState mk)) (CardanoEras c)
-> Maybe
     (Current
        (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra))
forall (f :: * -> *) c.
NS f (CardanoEras c)
-> Maybe (f (ShelleyBlock (TPraos c) ShelleyEra))
ejectShelleyNS (NS (Current (FlipTickedLedgerState mk)) (CardanoEras c)
 -> Maybe
      (Current
         (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra)))
-> NS (Current (FlipTickedLedgerState mk)) (CardanoEras c)
-> Maybe
     (Current
        (FlipTickedLedgerState mk) (ShelleyBlock (TPraos c) ShelleyEra))
forall a b. (a -> b) -> a -> b
$
      Telescope
  (K Past) (Current (FlipTickedLedgerState mk)) (CardanoEras c)
-> NS (Current (FlipTickedLedgerState mk)) (CardanoEras c)
forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Tele.tip (Telescope
   (K Past) (Current (FlipTickedLedgerState mk)) (CardanoEras c)
 -> NS (Current (FlipTickedLedgerState mk)) (CardanoEras c))
-> Telescope
     (K Past) (Current (FlipTickedLedgerState mk)) (CardanoEras c)
-> NS (Current (FlipTickedLedgerState mk)) (CardanoEras c)
forall a b. (a -> b) -> a -> b
$
        HardForkState (FlipTickedLedgerState mk) (CardanoEras c)
-> Telescope
     (K Past) (Current (FlipTickedLedgerState mk)) (CardanoEras c)
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState (HardForkState (FlipTickedLedgerState mk) (CardanoEras c)
 -> Telescope
      (K Past) (Current (FlipTickedLedgerState mk)) (CardanoEras c))
-> HardForkState (FlipTickedLedgerState mk) (CardanoEras c)
-> Telescope
     (K Past) (Current (FlipTickedLedgerState mk)) (CardanoEras c)
forall a b. (a -> b) -> a -> b
$
          TickedLedgerState (CardanoBlock c) mk
-> HardForkState (FlipTickedLedgerState mk) (CardanoEras c)
forall (xs :: [*]) (mk :: MapKind).
Ticked (LedgerState (HardForkBlock xs)) mk
-> HardForkState (FlipTickedLedgerState mk) xs
tickedHardForkLedgerStatePerEra (TickedLedgerState (CardanoBlock c) mk
 -> HardForkState (FlipTickedLedgerState mk) (CardanoEras c))
-> TickedLedgerState (CardanoBlock c) mk
-> HardForkState (FlipTickedLedgerState mk) (CardanoEras c)
forall a b. (a -> b) -> a -> b
$
            TickedLedgerState (CardanoBlock c) mk
ls