{-# 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
(AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool)
-> (AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool)
-> Eq AbstractToConcreteIdMaps
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
== :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
$c/= :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
/= :: AbstractToConcreteIdMaps -> AbstractToConcreteIdMaps -> Bool
Eq, (forall x.
 AbstractToConcreteIdMaps -> Rep AbstractToConcreteIdMaps x)
-> (forall x.
    Rep AbstractToConcreteIdMaps x -> AbstractToConcreteIdMaps)
-> Generic AbstractToConcreteIdMaps
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
$cfrom :: forall x.
AbstractToConcreteIdMaps -> Rep AbstractToConcreteIdMaps x
from :: forall x.
AbstractToConcreteIdMaps -> Rep AbstractToConcreteIdMaps x
$cto :: forall x.
Rep AbstractToConcreteIdMaps x -> AbstractToConcreteIdMaps
to :: forall x.
Rep AbstractToConcreteIdMaps x -> AbstractToConcreteIdMaps
Generic, Int -> AbstractToConcreteIdMaps -> ShowS
[AbstractToConcreteIdMaps] -> ShowS
AbstractToConcreteIdMaps -> String
(Int -> AbstractToConcreteIdMaps -> ShowS)
-> (AbstractToConcreteIdMaps -> String)
-> ([AbstractToConcreteIdMaps] -> ShowS)
-> Show AbstractToConcreteIdMaps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AbstractToConcreteIdMaps -> ShowS
showsPrec :: Int -> AbstractToConcreteIdMaps -> ShowS
$cshow :: AbstractToConcreteIdMaps -> String
show :: AbstractToConcreteIdMaps -> String
$cshowList :: [AbstractToConcreteIdMaps] -> ShowS
showList :: [AbstractToConcreteIdMaps] -> ShowS
Show)

instance Monoid AbstractToConcreteIdMaps where
  mempty :: AbstractToConcreteIdMaps
mempty = Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
AbstractToConcreteIdMaps Map TxId TxId
forall a. Monoid a => a
mempty Map UpId UpId
forall a. Monoid a => a
mempty
  mconcat :: [AbstractToConcreteIdMaps] -> AbstractToConcreteIdMaps
mconcat [AbstractToConcreteIdMaps]
xs =
    Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
AbstractToConcreteIdMaps
      ([Map TxId TxId] -> Map TxId TxId
forall a. Monoid a => [a] -> a
mconcat ([Map TxId TxId] -> Map TxId TxId)
-> [Map TxId TxId] -> Map TxId TxId
forall a b. (a -> b) -> a -> b
$ (AbstractToConcreteIdMaps -> Map TxId TxId)
-> [AbstractToConcreteIdMaps] -> [Map TxId TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map AbstractToConcreteIdMaps -> Map TxId TxId
transactionIds [AbstractToConcreteIdMaps]
xs)
      ([Map UpId UpId] -> Map UpId UpId
forall a. Monoid a => [a] -> a
mconcat ([Map UpId UpId] -> Map UpId UpId)
-> [Map UpId UpId] -> Map UpId UpId
forall a b. (a -> b) -> a -> b
$ (AbstractToConcreteIdMaps -> Map UpId UpId)
-> [AbstractToConcreteIdMaps] -> [Map UpId UpId]
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 Map TxId TxId -> Map TxId TxId -> Map TxId TxId
forall a. Semigroup a => a -> a -> a
<> AbstractToConcreteIdMaps -> Map TxId TxId
transactionIds AbstractToConcreteIdMaps
b)
      (AbstractToConcreteIdMaps -> Map UpId UpId
proposalIds AbstractToConcreteIdMaps
a Map UpId UpId -> Map UpId UpId -> Map UpId UpId
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 (ProtVer -> ProtocolVersion) -> ProtVer -> ProtocolVersion
forall a b. (a -> b) -> a -> b
$ BlockBody -> ProtVer
Abstract._bProtVer (BlockBody -> ProtVer) -> BlockBody -> ProtVer
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
            (SwVer -> SoftwareVersion) -> SwVer -> SoftwareVersion
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 =
      (GenesisHash -> HeaderHash)
-> (HeaderHash -> HeaderHash)
-> Either GenesisHash HeaderHash
-> HeaderHash
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GenesisHash -> HeaderHash
Concrete.genesisHeaderHash HeaderHash -> HeaderHash
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity (Either GenesisHash HeaderHash -> HeaderHash)
-> Either GenesisHash HeaderHash -> HeaderHash
forall a b. (a -> b) -> a -> b
$ ChainValidationState -> Either GenesisHash HeaderHash
Concrete.cvsPreviousHash ChainValidationState
st

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

    issuer :: VKey
issuer = Block
abstractBlock Block -> Getting VKey Block VKey -> VKey
forall s a. s -> Getting a s a -> a
^. (BlockHeader -> Const VKey BlockHeader)
-> Block -> Const VKey Block
Lens' Block BlockHeader
Abstract.bHeader ((BlockHeader -> Const VKey BlockHeader)
 -> Block -> Const VKey Block)
-> ((VKey -> Const VKey VKey)
    -> BlockHeader -> Const VKey BlockHeader)
-> Getting VKey Block VKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (VKey -> Const VKey VKey) -> BlockHeader -> Const VKey BlockHeader
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 = [ATxAux ()] -> ATxPayload ()
forall a. [ATxAux a] -> ATxPayload a
UTxO.ATxPayload [ATxAux ()]
txPayload
        , bodySscPayload :: SscPayload
Concrete.bodySscPayload = SscPayload
Ssc.SscPayload
        , bodyDlgPayload :: Payload
Concrete.bodyDlgPayload = [Certificate] -> () -> Payload
forall a. [ACertificate a] -> a -> APayload a
Delegation.UnsafeAPayload [Certificate]
dcerts ()
        , bodyUpdatePayload :: APayload ()
Concrete.bodyUpdatePayload = APayload ()
updatePayload
        }

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

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

    updatePayload :: Update.APayload ()
    updatePayload :: APayload ()
updatePayload =
      Maybe (AProposal ()) -> [AVote ()] -> () -> APayload ()
forall a. Maybe (AProposal a) -> [AVote a] -> a -> APayload a
Update.APayload
        (((UProp, AProposal ()) -> AProposal ())
-> Maybe (UProp, AProposal ()) -> Maybe (AProposal ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UProp, AProposal ()) -> AProposal ()
forall a b. (a, b) -> b
snd Maybe (UProp, AProposal ())
maybeProposals)
        ( (Vote -> AVote ()) -> [Vote] -> [AVote ()]
forall a b. (a -> b) -> [a] -> [b]
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')
            ([Vote] -> [AVote ()]) -> [Vote] -> [AVote ()]
forall a b. (a -> b) -> a -> b
$ BlockBody -> [Vote]
Abstract._bUpdVotes
            (BlockBody -> [Vote]) -> BlockBody -> [Vote]
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, AProposal ())
maybeProposals =
      (UProp -> (UProp, AProposal ()))
-> Maybe UProp -> Maybe (UProp, AProposal ())
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UProp -> UProp
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity (UProp -> UProp)
-> (UProp -> AProposal ()) -> UProp -> (UProp, AProposal ())
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ProtocolMagicId -> UProp -> AProposal ()
elaborateUpdateProposal ProtocolMagicId
pm)
        (Maybe UProp -> Maybe (UProp, AProposal ()))
-> Maybe UProp -> Maybe (UProp, AProposal ())
forall a b. (a -> b) -> a -> b
$ BlockBody -> Maybe UProp
Abstract._bUpdProp
        (BlockBody -> Maybe UProp) -> BlockBody -> Maybe UProp
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' = Map UpId UpId
-> ((UProp, AProposal ()) -> Map UpId UpId)
-> Maybe (UProp, AProposal ())
-> Map UpId UpId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map UpId UpId
proposalsIdMap (UProp, AProposal ()) -> Map UpId UpId
addUpdateProposalId Maybe (UProp, AProposal ())
maybeProposals
      where
        addUpdateProposalId :: (UProp, AProposal ()) -> Map UpId UpId
addUpdateProposalId (UProp
abstractProposal, AProposal ()
concreteProposal) =
          UpId -> UpId -> Map UpId UpId -> Map UpId UpId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
            (UProp -> UpId
Abstract.Update._upId UProp
abstractProposal)
            (AProposal () -> UpId
forall a. EncCBOR a => a -> Hash a
H.serializeCborHash AProposal ()
concreteProposal)
            Map UpId UpId
proposalsIdMap

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

            possiblyAlteredUTxOProof :: UTxO.TxProof
            possiblyAlteredUTxOProof :: TxProof
possiblyAlteredUTxOProof =
              if (Hash -> Bool
Abstract.isValid (Hash -> Bool) -> Hash -> Bool
forall a b. (a -> b) -> a -> b
$ BlockHeader -> Hash
Abstract._bhUtxoHash (BlockHeader -> Hash) -> BlockHeader -> Hash
forall a b. (a -> b) -> a -> b
$ Block -> BlockHeader
Abstract._bHeader Block
abstractBlock)
                then TxProof
originalUTxOProof
                else TxProof
originalUTxOProof {UTxO.txpWitnessesHash = coerce 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 (Hash -> Bool) -> Hash -> Bool
forall a b. (a -> b) -> a -> b
$ BlockHeader -> Hash
Abstract._bhDlgHash (BlockHeader -> Hash) -> BlockHeader -> Hash
forall a b. (a -> b) -> a -> b
$ Block -> BlockHeader
Abstract._bHeader Block
abstractBlock)
                then Proof -> Hash Payload
Concrete.proofDelegation Proof
originalHeaderProof
                else Hash Int -> Hash Payload
forall a b. Coercible a b => a -> b
coerce Hash Int
dummyHash

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

        dummyHash :: H.Hash Int
        dummyHash :: Hash Int
dummyHash = Int -> Hash Int
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 =
  (Block -> ABlock ByteString)
-> (Block, AbstractToConcreteIdMaps)
-> (ABlock ByteString, AbstractToConcreteIdMaps)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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))
    ((Block, AbstractToConcreteIdMaps)
 -> (ABlock ByteString, AbstractToConcreteIdMaps))
-> (Block, AbstractToConcreteIdMaps)
-> (ABlock ByteString, AbstractToConcreteIdMaps)
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 Version
-> Text
-> (forall s. Decoder s (ABlockOrBoundary ByteSpan))
-> ByteString
-> Either DecoderError (ABlockOrBoundary ByteSpan)
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
Binary.decodeFullDecoder
          Version
Binary.byronProtVer
          Text
"Block"
          (EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
forall s. EpochSlots -> Decoder s (ABlockOrBoundary ByteSpan)
Concrete.decCBORABlockOrBoundary EpochSlots
epochSlots)
          ByteString
bytes of
          Left DecoderError
err ->
            Text -> ABlockOrBoundary ByteString
forall a. HasCallStack => Text -> a
panic
              (Text -> ABlockOrBoundary ByteString)
-> Text -> ABlockOrBoundary ByteString
forall a b. (a -> b) -> a -> b
$ Text
"This function should be able to decode the block it encoded"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Instead I got: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DecoderError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show DecoderError
err
          Right ABlockOrBoundary ByteSpan
abobb -> (ByteSpan -> ByteString)
-> ABlockOrBoundary ByteSpan -> ABlockOrBoundary ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (ByteSpan -> ByteString) -> ByteSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
_ ->
          Text -> ABlock ByteString
forall a. HasCallStack => Text -> a
panic Text
"This function should have decoded a block."
  where
    bytes :: ByteString
bytes = Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
Binary.serialize Version
Binary.byronProtVer (EpochSlots -> Block -> Encoding
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 = (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
State CHAIN
ast (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
-> Getting
     (Bimap VKeyGenesis VKey)
     (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
     (Bimap VKeyGenesis VKey)
-> Bimap VKeyGenesis VKey
forall s a. s -> Getting a s a -> a
^. (DIState -> Const (Bimap VKeyGenesis VKey) DIState)
-> (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
-> Const
     (Bimap VKeyGenesis VKey)
     (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
(DIState -> Const (Bimap VKeyGenesis VKey) DIState)
-> State CHAIN -> Const (Bimap VKeyGenesis VKey) (State CHAIN)
Lens' (State CHAIN) DIState
disL ((DIState -> Const (Bimap VKeyGenesis VKey) DIState)
 -> (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
 -> Const
      (Bimap VKeyGenesis VKey)
      (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState))
-> ((Bimap VKeyGenesis VKey
     -> Const (Bimap VKeyGenesis VKey) (Bimap VKeyGenesis VKey))
    -> DIState -> Const (Bimap VKeyGenesis VKey) DIState)
-> Getting
     (Bimap VKeyGenesis VKey)
     (Slot, Seq VKeyGenesis, Hash, UTxOState, DIState, UPIState)
     (Bimap VKeyGenesis VKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Bimap VKeyGenesis VKey
 -> Const (Bimap VKeyGenesis VKey) (Bimap VKeyGenesis VKey))
-> DIState -> Const (Bimap VKeyGenesis VKey) DIState
forall s a. HasDelegationMap s a => Lens' s a
Lens' DIState (Bimap VKeyGenesis VKey)
delegationMap

    vkg :: VKeyGenesis
vkg = VKeyGenesis -> Maybe VKeyGenesis -> VKeyGenesis
forall a. a -> Maybe a -> a
fromMaybe VKeyGenesis
err (Maybe VKeyGenesis -> VKeyGenesis)
-> Maybe VKeyGenesis -> VKeyGenesis
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 = Text -> VKeyGenesis
forall a. HasCallStack => Text -> a
panic (Text -> VKeyGenesis) -> Text -> VKeyGenesis
forall a b. (a -> b) -> a -> b
$ Text
"No delegator found for key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VKey -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show VKey
vk

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

    sigVkgEpoch :: Sig (VKey, Epoch)
sigVkgEpoch = SKey -> (VKey, Epoch) -> Sig (VKey, Epoch)
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
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 = AProtocolMagic ByteString -> RequiresNetworkMagic
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 (Word64 -> BlockCount) -> Word64 -> 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 (Hash Raw -> GenesisHash) -> Hash Raw -> GenesisHash
forall a b. (a -> b) -> a -> b
$ Hash ByteString -> Hash Raw
forall a b. Coercible a b => a -> b
coerce (Hash ByteString -> Hash Raw) -> Hash ByteString -> Hash Raw
forall a b. (a -> b) -> a -> b
$ ByteString -> Hash ByteString
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 =
      (VKeyGenesis -> KeyHash) -> Set VKeyGenesis -> Set KeyHash
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (VerificationKey -> KeyHash
hashKey (VerificationKey -> KeyHash)
-> (VKeyGenesis -> VerificationKey) -> VKeyGenesis -> KeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
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