{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}

-- | This module provides functionality for translating abstract blocks into
-- concrete blocks. The abstract blocks are generated according the small-step
-- rules for the blockchain (also called the blockchain specification).
module Test.Cardano.Chain.Elaboration.Block (
  abEnvToCfg,
  elaborate,
  elaborateBS,
  rcDCert,
  AbstractToConcreteIdMaps (
    AbstractToConcreteIdMaps,
    proposalIds,
    transactionIds
  ),
)
where

import qualified Byron.Spec.Chain.STS.Block as Abstract
import Byron.Spec.Chain.STS.Rule.Chain (CHAIN, disL)
import qualified Byron.Spec.Chain.STS.Rule.Epoch as Abstract
import qualified Byron.Spec.Ledger.Core as Abstract
import Byron.Spec.Ledger.Delegation (
  DCert,
  delegationMap,
  delegatorOf,
  mkDCert,
 )
import qualified Byron.Spec.Ledger.UTxO as Abstract
import qualified Byron.Spec.Ledger.Update as Abstract.Update
import qualified Cardano.Chain.Block as Concrete
import Cardano.Chain.Common (
  BlockCount (BlockCount),
  ChainDifficulty (ChainDifficulty),
  hashKey,
 )
import qualified Cardano.Chain.Common as Common
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Genesis as Genesis
import qualified Cardano.Chain.Slotting as Slotting
import qualified Cardano.Chain.Ssc as Ssc
import qualified Cardano.Chain.UTxO as UTxO
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Crypto.Hashing as H
import Cardano.Crypto.ProtocolMagic (AProtocolMagic (..))
import qualified Cardano.Ledger.Binary as Binary
import Cardano.Prelude hiding (to)
import Control.Arrow ((&&&))
import qualified Control.State.Transition as Transition
import Data.Bimap (Bimap)
import qualified Data.ByteString.Lazy as LBS
import Data.Coerce (coerce)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Time (Day (ModifiedJulianDay), UTCTime (UTCTime))
import Lens.Micro (to, (^.), (^..))
import Test.Cardano.Chain.Elaboration.Delegation (elaborateDCert)
import Test.Cardano.Chain.Elaboration.Keys (
  elaborateVKeyGenesis,
  vKeyPair,
  vKeyToSKey,
 )
import Test.Cardano.Chain.Elaboration.Update (
  elaboratePParams,
  elaborateProtocolVersion,
  elaborateSoftwareVersion,
  elaborateUpdateProposal,
  elaborateVote,
 )
import Test.Cardano.Chain.UTxO.Model (elaborateTxWitnesses)
import qualified Test.Cardano.Crypto.Dummy as Dummy

data AbstractToConcreteIdMaps = AbstractToConcreteIdMaps
  { AbstractToConcreteIdMaps -> Map TxId TxId
transactionIds :: !(Map Abstract.TxId UTxO.TxId)
  , AbstractToConcreteIdMaps -> Map UpId UpId
proposalIds :: !(Map Abstract.Update.UpId Update.UpId)
  }
  deriving (AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
$c/= :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
== :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
$c== :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
Eq, forall x.
Rep AbstractToConcreteIdMaps x -> AbstractToConcreteIdMaps
forall x.
AbstractToConcreteIdMaps -> Rep AbstractToConcreteIdMaps x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep AbstractToConcreteIdMaps x -> AbstractToConcreteIdMaps
$cfrom :: forall x.
AbstractToConcreteIdMaps -> Rep AbstractToConcreteIdMaps x
Generic, Int -> AbstractToConcreteIdMaps -> ShowS
[AbstractToConcreteIdMaps] -> ShowS
AbstractToConcreteIdMaps -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AbstractToConcreteIdMaps] -> ShowS
$cshowList :: [AbstractToConcreteIdMaps] -> ShowS
show :: AbstractToConcreteIdMaps -> String
$cshow :: AbstractToConcreteIdMaps -> String
showsPrec :: Int -> AbstractToConcreteIdMaps -> ShowS
$cshowsPrec :: Int -> AbstractToConcreteIdMaps -> ShowS
Show)

instance Monoid AbstractToConcreteIdMaps where
  mempty :: AbstractToConcreteIdMaps
mempty = Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
AbstractToConcreteIdMaps forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  mconcat :: [AbstractToConcreteIdMaps] -> AbstractToConcreteIdMaps
mconcat [AbstractToConcreteIdMaps]
xs =
    Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
AbstractToConcreteIdMaps
      (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map AbstractToConcreteIdMaps -> Map TxId TxId
transactionIds [AbstractToConcreteIdMaps]
xs)
      (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map AbstractToConcreteIdMaps -> Map UpId UpId
proposalIds [AbstractToConcreteIdMaps]
xs)

instance Semigroup AbstractToConcreteIdMaps where
  AbstractToConcreteIdMaps
a <> :: AbstractToConcreteIdMaps
-> AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps
<> AbstractToConcreteIdMaps
b =
    Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
AbstractToConcreteIdMaps
      (AbstractToConcreteIdMaps -> Map TxId TxId
transactionIds AbstractToConcreteIdMaps
a forall a. Semigroup a => a -> a -> a
<> AbstractToConcreteIdMaps -> Map TxId TxId
transactionIds AbstractToConcreteIdMaps
b)
      (AbstractToConcreteIdMaps -> Map UpId UpId
proposalIds AbstractToConcreteIdMaps
a forall a. Semigroup a => a -> a -> a
<> AbstractToConcreteIdMaps -> Map UpId UpId
proposalIds AbstractToConcreteIdMaps
b)

-- | Elaborate an abstract block into a concrete block (without annotations).
elaborate ::
  AbstractToConcreteIdMaps ->
  Genesis.Config ->
  DCert ->
  Concrete.ChainValidationState ->
  Abstract.Block ->
  (Concrete.Block, AbstractToConcreteIdMaps)
elaborate :: AbstractToConcreteIdMaps
-> Config
-> DCert
-> ChainValidationState
-> Block
-> (Block, AbstractToConcreteIdMaps)
elaborate AbstractToConcreteIdMaps
abstractToConcreteIdMaps Config
config DCert
dCert ChainValidationState
st Block
abstractBlock =
  ( Concrete.ABlock
      { blockHeader :: AHeader ()
Concrete.blockHeader = AHeader () -> AHeader ()
recomputeHashes AHeader ()
bh0
      , blockBody :: ABody ()
Concrete.blockBody = ABody ()
bb0
      , blockAnnotation :: ()
Concrete.blockAnnotation = ()
      }
  , AbstractToConcreteIdMaps
      { transactionIds :: Map TxId TxId
transactionIds = Map TxId TxId
txIdMap'
      , proposalIds :: Map UpId UpId
proposalIds = Map UpId UpId
proposalsIdMap'
      }
  )
  where
    AbstractToConcreteIdMaps Map TxId TxId
txIdMap Map UpId UpId
proposalsIdMap = AbstractToConcreteIdMaps
abstractToConcreteIdMaps

    pm :: ProtocolMagicId
pm = Config -> ProtocolMagicId
Genesis.configProtocolMagicId Config
config

    bh0 :: AHeader ()
bh0 =
      ProtocolMagicId
-> HeaderHash
-> ChainDifficulty
-> EpochSlots
-> SlotNumber
-> SigningKey
-> Certificate
-> ABody ()
-> ProtocolVersion
-> SoftwareVersion
-> AHeader ()
Concrete.mkHeaderExplicit
        ProtocolMagicId
pm
        HeaderHash
prevHash
        (Word64 -> ChainDifficulty
ChainDifficulty Word64
0)
        (Config -> EpochSlots
Genesis.configEpochSlots Config
config)
        SlotNumber
sid
        SigningKey
ssk
        Certificate
cDCert
        ABody ()
bb0
        (ProtVer -> ProtocolVersion
elaborateProtocolVersion forall a b. (a -> b) -> a -> b
$ BlockBody -> ProtVer
Abstract._bProtVer forall a b. (a -> b) -> a -> b
$ Block -> BlockBody
Abstract._bBody Block
abstractBlock)
        -- TODO: the Byron spec needs to incorporate a software version in the blocks
        ( SwVer -> SoftwareVersion
elaborateSoftwareVersion
            forall a b. (a -> b) -> a -> b
$ ApName -> ApVer -> SwVer
Abstract.Update.SwVer (String -> ApName
Abstract.Update.ApName String
"") (Natural -> ApVer
Abstract.Update.ApVer Natural
0)
        )

    prevHash :: Concrete.HeaderHash
    prevHash :: HeaderHash
prevHash =
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GenesisHash -> HeaderHash
Concrete.genesisHeaderHash forall (cat :: * -> * -> *) a. Category cat => cat a a
identity forall a b. (a -> b) -> a -> b
$ ChainValidationState -> Either GenesisHash HeaderHash
Concrete.cvsPreviousHash ChainValidationState
st

    sid :: SlotNumber
sid =
      Word64 -> SlotNumber
Slotting.SlotNumber
        (Block
abstractBlock forall s a. s -> Getting a s a -> a
^. Lens' Block BlockHeader
Abstract.bHeader forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' BlockHeader Slot
Abstract.bhSlot forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s a. (s -> a) -> SimpleGetter s a
to Slot -> Word64
Abstract.unSlot)

    issuer :: VKey
issuer = Block
abstractBlock forall s a. s -> Getting a s a -> a
^. Lens' Block BlockHeader
Abstract.bHeader forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' BlockHeader VKey
Abstract.bhIssuer

    ssk :: SigningKey
ssk = VKey -> SigningKey
vKeyToSKey VKey
issuer

    cDCert :: Delegation.Certificate
    cDCert :: Certificate
cDCert = ProtocolMagicId -> DCert -> Certificate
elaborateDCert ProtocolMagicId
pm DCert
dCert

    bb0 :: ABody ()
bb0 =
      Concrete.ABody
        { bodyTxPayload :: ATxPayload ()
Concrete.bodyTxPayload = forall a. [ATxAux a] -> ATxPayload a
UTxO.ATxPayload [ATxAux ()]
txPayload
        , bodySscPayload :: SscPayload
Concrete.bodySscPayload = SscPayload
Ssc.SscPayload
        , bodyDlgPayload :: Payload
Concrete.bodyDlgPayload = forall a. [ACertificate a] -> a -> APayload a
Delegation.UnsafeAPayload [Certificate]
dcerts ()
        , bodyUpdatePayload :: APayload ()
Concrete.bodyUpdatePayload = APayload ()
updatePayload
        }

    dcerts :: [Certificate]
dcerts =
      Block
abstractBlock
        forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ( Lens' Block BlockBody
Abstract.bBody
                forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' BlockBody [DCert]
Abstract.bDCerts
                forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s a. (s -> a) -> SimpleGetter s a
to
                  (ProtocolMagicId -> DCert -> Certificate
elaborateDCert ProtocolMagicId
pm)
            )

    ([ATxAux ()]
txPayload, Map TxId TxId
txIdMap') =
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Functor f => f a -> f ()
void)
        forall a b. (a -> b) -> a -> b
$ Map TxId TxId -> [Tx] -> ([ATxAux ByteString], Map TxId TxId)
elaborateTxWitnesses
          Map TxId TxId
txIdMap
          (Block
abstractBlock forall s a. s -> Getting a s a -> a
^. Lens' Block BlockBody
Abstract.bBody forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' BlockBody [Tx]
Abstract.bUtxo)

    updatePayload :: Update.APayload ()
    updatePayload :: APayload ()
updatePayload =
      forall a. Maybe (AProposal a) -> [AVote a] -> a -> APayload a
Update.APayload
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Maybe (UProp, Proposal)
maybeProposals)
        ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ProtocolMagicId -> Map UpId UpId -> Vote -> AVote ()
elaborateVote ProtocolMagicId
pm Map UpId UpId
proposalsIdMap')
            forall a b. (a -> b) -> a -> b
$ BlockBody -> [Vote]
Abstract._bUpdVotes
            forall a b. (a -> b) -> a -> b
$ Block -> BlockBody
Abstract._bBody Block
abstractBlock
        )
        () -- Update payload annotation
    maybeProposals :: Maybe (Abstract.Update.UProp, Update.Proposal)
    maybeProposals :: Maybe (UProp, Proposal)
maybeProposals =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (cat :: * -> * -> *) a. Category cat => cat a a
identity forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ProtocolMagicId -> UProp -> Proposal
elaborateUpdateProposal ProtocolMagicId
pm)
        forall a b. (a -> b) -> a -> b
$ BlockBody -> Maybe UProp
Abstract._bUpdProp
        forall a b. (a -> b) -> a -> b
$ Block -> BlockBody
Abstract._bBody Block
abstractBlock

    proposalsIdMap' :: Map Abstract.Update.UpId Update.UpId
    proposalsIdMap' :: Map UpId UpId
proposalsIdMap' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map UpId UpId
proposalsIdMap (UProp, Proposal) -> Map UpId UpId
addUpdateProposalId Maybe (UProp, Proposal)
maybeProposals
      where
        addUpdateProposalId :: (UProp, Proposal) -> Map UpId UpId
addUpdateProposalId (UProp
abstractProposal, Proposal
concreteProposal) =
          forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
            (UProp -> UpId
Abstract.Update._upId UProp
abstractProposal)
            (forall a. EncCBOR a => a -> Hash a
H.serializeCborHash Proposal
concreteProposal)
            Map UpId UpId
proposalsIdMap

    recomputeHashes :: Concrete.AHeader () -> Concrete.AHeader ()
    recomputeHashes :: AHeader () -> AHeader ()
recomputeHashes AHeader ()
concreteHeader =
      AHeader ()
concreteHeader {aHeaderProof :: Annotated Proof ()
Concrete.aHeaderProof = forall b a. b -> a -> Annotated b a
Binary.Annotated Proof
alteredHdrProof ()}
      where
        alteredHdrProof :: Concrete.Proof
        alteredHdrProof :: Proof
alteredHdrProof =
          Proof
originalHeaderProof
            { proofDelegation :: Hash Payload
Concrete.proofDelegation = Hash Payload
possiblyAlteredDelegationProof
            , proofUpdate :: Proof
Concrete.proofUpdate = Proof
possiblyAlteredUpdateProof
            , proofUTxO :: TxProof
Concrete.proofUTxO = TxProof
possiblyAlteredUTxOProof
            }
          where
            originalHeaderProof :: Concrete.Proof
            originalHeaderProof :: Proof
originalHeaderProof =
              forall b a. Annotated b a -> b
Binary.unAnnotated (forall a. AHeader a -> Annotated Proof a
Concrete.aHeaderProof AHeader ()
concreteHeader)

            possiblyAlteredUTxOProof :: UTxO.TxProof
            possiblyAlteredUTxOProof :: TxProof
possiblyAlteredUTxOProof =
              if (Hash -> Bool
Abstract.isValid forall a b. (a -> b) -> a -> b
$ BlockHeader -> Hash
Abstract._bhUtxoHash forall a b. (a -> b) -> a -> b
$ Block -> BlockHeader
Abstract._bHeader Block
abstractBlock)
                then TxProof
originalUTxOProof
                else TxProof
originalUTxOProof {txpWitnessesHash :: Hash [TxWitness]
UTxO.txpWitnessesHash = coerce :: forall a b. Coercible a b => a -> b
coerce Hash Int
dummyHash}
              where
                originalUTxOProof :: UTxO.TxProof
                originalUTxOProof :: TxProof
originalUTxOProof = Proof -> TxProof
Concrete.proofUTxO Proof
originalHeaderProof

            possiblyAlteredDelegationProof :: H.Hash Delegation.Payload
            possiblyAlteredDelegationProof :: Hash Payload
possiblyAlteredDelegationProof =
              if (Hash -> Bool
Abstract.isValid forall a b. (a -> b) -> a -> b
$ BlockHeader -> Hash
Abstract._bhDlgHash forall a b. (a -> b) -> a -> b
$ Block -> BlockHeader
Abstract._bHeader Block
abstractBlock)
                then Proof -> Hash Payload
Concrete.proofDelegation Proof
originalHeaderProof
                else coerce :: forall a b. Coercible a b => a -> b
coerce Hash Int
dummyHash

            possiblyAlteredUpdateProof :: Update.Proof
            possiblyAlteredUpdateProof :: Proof
possiblyAlteredUpdateProof =
              if (Hash -> Bool
Abstract.isValid forall a b. (a -> b) -> a -> b
$ BlockHeader -> Hash
Abstract._bhUpdHash forall a b. (a -> b) -> a -> b
$ Block -> BlockHeader
Abstract._bHeader Block
abstractBlock)
                then Proof -> Proof
Concrete.proofUpdate Proof
originalHeaderProof
                else coerce :: forall a b. Coercible a b => a -> b
coerce Hash Int
dummyHash

        dummyHash :: H.Hash Int
        dummyHash :: Hash Int
dummyHash = forall a. EncCBOR a => a -> Hash a
H.serializeCborHash Int
0

elaborateBS ::
  AbstractToConcreteIdMaps ->
  Genesis.Config -> -- TODO: Do we want this to come from the abstract
  -- environment? (in such case we wouldn't need this
  -- parameter)
  DCert ->
  Concrete.ChainValidationState ->
  Abstract.Block ->
  (Concrete.ABlock ByteString, AbstractToConcreteIdMaps)
elaborateBS :: AbstractToConcreteIdMaps
-> Config
-> DCert
-> ChainValidationState
-> Block
-> (ABlock ByteString, AbstractToConcreteIdMaps)
elaborateBS AbstractToConcreteIdMaps
txIdMap Config
config DCert
dCert ChainValidationState
st Block
ab =
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (EpochSlots -> Block -> ABlock ByteString
annotateBlock (Config -> EpochSlots
Genesis.configEpochSlots Config
config))
    forall a b. (a -> b) -> a -> b
$ AbstractToConcreteIdMaps
-> Config
-> DCert
-> ChainValidationState
-> Block
-> (Block, AbstractToConcreteIdMaps)
elaborate AbstractToConcreteIdMaps
txIdMap Config
config DCert
dCert ChainValidationState
st Block
ab

annotateBlock :: Slotting.EpochSlots -> Concrete.Block -> Concrete.ABlock ByteString
annotateBlock :: EpochSlots -> Block -> ABlock ByteString
annotateBlock EpochSlots
epochSlots Block
block =
  let decodedABlockOrBoundary :: ABlockOrBoundary ByteString
decodedABlockOrBoundary =
        case forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
Binary.decodeFullDecoder
          Version
Binary.byronProtVer
          Text
"Block"
          (forall s. EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
Concrete.decCBORABlockOrBoundary EpochSlots
epochSlots)
          ByteString
bytes of
          Left DecoderError
err ->
            forall a. HasCallStack => Text -> a
panic
              forall a b. (a -> b) -> a -> b
$ Text
"This function should be able to decode the block it encoded"
              forall a. Semigroup a => a -> a -> a
<> Text
". Instead I got: "
              forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show DecoderError
err
          Right ABlockOrBoundary ByteSpan
abobb -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> ByteString
LBS.toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteSpan -> ByteString
Binary.slice ByteString
bytes) ABlockOrBoundary ByteSpan
abobb
   in case ABlockOrBoundary ByteString
decodedABlockOrBoundary of
        Concrete.ABOBBlock ABlock ByteString
bk -> ABlock ByteString
bk
        Concrete.ABOBBoundary ABoundaryBlock ByteString
_ ->
          forall a. HasCallStack => Text -> a
panic Text
"This function should have decoded a block."
  where
    bytes :: ByteString
bytes = forall a. EncCBOR a => Version -> a -> ByteString
Binary.serialize Version
Binary.byronProtVer (forall a. EpochSlots -> ABlock a -> Encoding
Concrete.encCBORABOBBlock EpochSlots
epochSlots Block
block)

-- | Re-construct an abstract delegation certificate from the abstract state.
--
-- We need to do this because the delegation certificate is included in the
-- block.
rcDCert ::
  HasCallStack =>
  -- | Key for which the delegation certificate is being constructed.
  Abstract.VKey ->
  -- | Chain stability parameter
  Abstract.BlockCount ->
  Transition.State CHAIN ->
  DCert
rcDCert :: HasCallStack => VKey -> BlockCount -> State CHAIN -> DCert
rcDCert VKey
vk BlockCount
k ast :: State CHAIN
ast@(Slot
slot, Seq VKeyGenesis
_, Hash
_, UTxOState
_, DIState
_, UPIState
_) =
  VKeyGenesis -> Sig (VKey, Epoch) -> VKey -> Epoch -> DCert
mkDCert VKeyGenesis
vkg Sig (VKey, Epoch)
sigVkgEpoch VKey
vk Epoch
epoch
  where
    dm :: Bimap Abstract.VKeyGenesis Abstract.VKey
    dm :: Bimap VKeyGenesis VKey
dm = State CHAIN
ast forall s a. s -> Getting a s a -> a
^. Lens' (State CHAIN) DIState
disL forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s a. HasDelegationMap s a => Lens' s a
delegationMap

    vkg :: VKeyGenesis
vkg = forall a. a -> Maybe a -> a
fromMaybe VKeyGenesis
err forall a b. (a -> b) -> a -> b
$ Bimap VKeyGenesis VKey -> VKey -> Maybe VKeyGenesis
delegatorOf Bimap VKeyGenesis VKey
dm VKey
vk

    err :: Abstract.VKeyGenesis
    err :: VKeyGenesis
err = forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"No delegator found for key " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show VKey
vk

    vkp :: KeyPair
vkp = VKey -> KeyPair
vKeyPair forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce VKeyGenesis
vkg

    sigVkgEpoch :: Sig (VKey, Epoch)
sigVkgEpoch = forall a. SKey -> a -> Sig a
Abstract.sign (KeyPair -> SKey
Abstract.sKey KeyPair
vkp) (VKey
vk, Epoch
epoch)

    epoch :: Epoch
epoch = HasCallStack => Slot -> BlockCount -> Epoch
Abstract.sEpoch Slot
slot BlockCount
k

-- | Make a genesis configuration from an initial abstract environment of the
--   trace.
abEnvToCfg :: Transition.Environment CHAIN -> Genesis.Config
abEnvToCfg :: Environment CHAIN -> Config
abEnvToCfg (Slot
_currentSlot, UTxO
_genesisUtxo, Set VKeyGenesis
allowedDelegators, PParams
protocolParams, BlockCount
stableAfter) =
  Genesis.Config
    { configGenesisData :: GenesisData
Genesis.configGenesisData = GenesisData
genesisData
    , configGenesisHash :: GenesisHash
Genesis.configGenesisHash = GenesisHash
genesisHash
    , configReqNetMagic :: RequiresNetworkMagic
Genesis.configReqNetMagic = RequiresNetworkMagic
rnm
    , configUTxOConfiguration :: UTxOConfiguration
Genesis.configUTxOConfiguration = UTxOConfiguration
UTxO.defaultUTxOConfiguration
    }
  where
    rnm :: RequiresNetworkMagic
rnm = forall a. AProtocolMagic a -> RequiresNetworkMagic
getRequiresNetworkMagic AProtocolMagic ByteString
Dummy.aProtocolMagic

    genesisData :: GenesisData
genesisData =
      Genesis.GenesisData
        { gdGenesisKeyHashes :: GenesisKeyHashes
Genesis.gdGenesisKeyHashes = Set KeyHash -> GenesisKeyHashes
Genesis.GenesisKeyHashes Set KeyHash
genesisKeyHashes
        , gdHeavyDelegation :: GenesisDelegation
Genesis.gdHeavyDelegation = Map KeyHash Certificate -> GenesisDelegation
Genesis.UnsafeGenesisDelegation [] -- We don't need initial heavyweight delegation.
        , gdStartTime :: UTCTime
Genesis.gdStartTime = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0
        , gdNonAvvmBalances :: GenesisNonAvvmBalances
Genesis.gdNonAvvmBalances = Map Address Lovelace -> GenesisNonAvvmBalances
Genesis.GenesisNonAvvmBalances []
        , gdProtocolParameters :: ProtocolParameters
Genesis.gdProtocolParameters = ProtocolParameters
gPps
        , gdK :: BlockCount
Genesis.gdK = Word64 -> BlockCount
BlockCount forall a b. (a -> b) -> a -> b
$ BlockCount -> Word64
Abstract.unBlockCount BlockCount
stableAfter
        , gdProtocolMagicId :: ProtocolMagicId
Genesis.gdProtocolMagicId = ProtocolMagicId
Dummy.protocolMagicId
        , gdAvvmDistr :: GenesisAvvmBalances
Genesis.gdAvvmDistr = Map CompactRedeemVerificationKey Lovelace -> GenesisAvvmBalances
Genesis.GenesisAvvmBalances []
        }

    -- We shouldn't need to use 'coerce' after
    -- https://github.com/intersectmbo/cardano-ledger/issues/332 gets
    -- implemented.
    genesisHash :: GenesisHash
genesisHash = Hash Raw -> GenesisHash
Genesis.GenesisHash forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Hash a
H.serializeCborHash (ByteString
"" :: ByteString)

    gPps :: ProtocolParameters
gPps = PParams -> ProtocolParameters
elaboratePParams PParams
protocolParams

    genesisKeyHashes :: Set Common.KeyHash
    genesisKeyHashes :: Set KeyHash
genesisKeyHashes =
      forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (VerificationKey -> KeyHash
hashKey forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. VKeyGenesis -> VerificationKey
elaborateVKeyGenesis) Set VKeyGenesis
allowedDelegators