{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.ByronDual.Ledger (
    -- * Shorthand
    DualByronBlock
  , DualByronBridge
    -- * Bridge
  , ByronSpecBridge (..)
  , SpecToImplIds (..)
  , bridgeToSpecKey
  , bridgeTransactionIds
  , initByronSpecBridge
  , specToImplTx
    -- * Block forging
  , forgeDualByronBlock
  ) where

import qualified Byron.Spec.Ledger.Core as Spec
import qualified Byron.Spec.Ledger.UTxO as Spec
import qualified Cardano.Chain.UTxO as Impl
import           Cardano.Crypto.DSIGN.Class
import           Codec.Serialise
import           Data.ByteString (ByteString)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import           GHC.Generics (Generic)
import           GHC.Stack
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Byron.Crypto.DSIGN
import           Ouroboros.Consensus.Byron.Ledger
import           Ouroboros.Consensus.Byron.Protocol
import           Ouroboros.Consensus.ByronSpec.Ledger
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Dual
import qualified Ouroboros.Consensus.Mempool as Mempool
import           Ouroboros.Consensus.Protocol.PBFT
import qualified Test.Cardano.Chain.Elaboration.Block as Spec.Test
import qualified Test.Cardano.Chain.Elaboration.Keys as Spec.Test

{-------------------------------------------------------------------------------
  Shorthand
-------------------------------------------------------------------------------}

type DualByronBlock  = DualBlock    ByronBlock ByronSpecBlock
type DualByronBridge = BridgeLedger ByronBlock ByronSpecBlock

{-------------------------------------------------------------------------------
  Map transaction Ids (part of the bridge)
-------------------------------------------------------------------------------}

newtype SpecToImplIds = SpecToImplIds {
      SpecToImplIds -> AbstractToConcreteIdMaps
getSpecToImplIds :: Spec.Test.AbstractToConcreteIdMaps
    }
  deriving (Int -> SpecToImplIds -> ShowS
[SpecToImplIds] -> ShowS
SpecToImplIds -> String
(Int -> SpecToImplIds -> ShowS)
-> (SpecToImplIds -> String)
-> ([SpecToImplIds] -> ShowS)
-> Show SpecToImplIds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpecToImplIds] -> ShowS
$cshowList :: [SpecToImplIds] -> ShowS
show :: SpecToImplIds -> String
$cshow :: SpecToImplIds -> String
showsPrec :: Int -> SpecToImplIds -> ShowS
$cshowsPrec :: Int -> SpecToImplIds -> ShowS
Show, SpecToImplIds -> SpecToImplIds -> Bool
(SpecToImplIds -> SpecToImplIds -> Bool)
-> (SpecToImplIds -> SpecToImplIds -> Bool) -> Eq SpecToImplIds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpecToImplIds -> SpecToImplIds -> Bool
$c/= :: SpecToImplIds -> SpecToImplIds -> Bool
== :: SpecToImplIds -> SpecToImplIds -> Bool
$c== :: SpecToImplIds -> SpecToImplIds -> Bool
Eq, (forall x. SpecToImplIds -> Rep SpecToImplIds x)
-> (forall x. Rep SpecToImplIds x -> SpecToImplIds)
-> Generic SpecToImplIds
forall x. Rep SpecToImplIds x -> SpecToImplIds
forall x. SpecToImplIds -> Rep SpecToImplIds x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SpecToImplIds x -> SpecToImplIds
$cfrom :: forall x. SpecToImplIds -> Rep SpecToImplIds x
Generic, [SpecToImplIds] -> Encoding
SpecToImplIds -> Encoding
(SpecToImplIds -> Encoding)
-> (forall s. Decoder s SpecToImplIds)
-> ([SpecToImplIds] -> Encoding)
-> (forall s. Decoder s [SpecToImplIds])
-> Serialise SpecToImplIds
forall s. Decoder s [SpecToImplIds]
forall s. Decoder s SpecToImplIds
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: Decoder s [SpecToImplIds]
$cdecodeList :: forall s. Decoder s [SpecToImplIds]
encodeList :: [SpecToImplIds] -> Encoding
$cencodeList :: [SpecToImplIds] -> Encoding
decode :: Decoder s SpecToImplIds
$cdecode :: forall s. Decoder s SpecToImplIds
encode :: SpecToImplIds -> Encoding
$cencode :: SpecToImplIds -> Encoding
Serialise)

instance Semigroup SpecToImplIds where
  SpecToImplIds AbstractToConcreteIdMaps
a <> :: SpecToImplIds -> SpecToImplIds -> SpecToImplIds
<> SpecToImplIds AbstractToConcreteIdMaps
b =
      AbstractToConcreteIdMaps -> SpecToImplIds
SpecToImplIds (AbstractToConcreteIdMaps -> SpecToImplIds)
-> AbstractToConcreteIdMaps -> SpecToImplIds
forall a b. (a -> b) -> a -> b
$ AbstractToConcreteIdMaps :: Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
Spec.Test.AbstractToConcreteIdMaps {
          transactionIds :: Map TxId TxId
transactionIds = (AbstractToConcreteIdMaps -> Map TxId TxId) -> Map TxId TxId
forall x. Semigroup x => (AbstractToConcreteIdMaps -> x) -> x
combine AbstractToConcreteIdMaps -> Map TxId TxId
Spec.Test.transactionIds
        , proposalIds :: Map UpId UpId
proposalIds    = (AbstractToConcreteIdMaps -> Map UpId UpId) -> Map UpId UpId
forall x. Semigroup x => (AbstractToConcreteIdMaps -> x) -> x
combine AbstractToConcreteIdMaps -> Map UpId UpId
Spec.Test.proposalIds
        }
    where
      combine :: Semigroup x => (Spec.Test.AbstractToConcreteIdMaps -> x) -> x
      combine :: (AbstractToConcreteIdMaps -> x) -> x
combine AbstractToConcreteIdMaps -> x
f = AbstractToConcreteIdMaps -> x
f AbstractToConcreteIdMaps
a x -> x -> x
forall a. Semigroup a => a -> a -> a
<> AbstractToConcreteIdMaps -> x
f AbstractToConcreteIdMaps
b

instance Monoid SpecToImplIds where
  mempty :: SpecToImplIds
mempty = AbstractToConcreteIdMaps -> SpecToImplIds
SpecToImplIds AbstractToConcreteIdMaps :: Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
Spec.Test.AbstractToConcreteIdMaps {
        transactionIds :: Map TxId TxId
transactionIds = Map TxId TxId
forall a. Monoid a => a
mempty
      , proposalIds :: Map UpId UpId
proposalIds    = Map UpId UpId
forall a. Monoid a => a
mempty
      }

-- | Construct singleton 'SpecToImplIds' for a transaction
specToImplTx :: Spec.Tx -> Impl.ATxAux ByteString -> SpecToImplIds
specToImplTx :: Tx -> ATxAux ByteString -> SpecToImplIds
specToImplTx Tx
spec ATxAux ByteString
impl = AbstractToConcreteIdMaps -> SpecToImplIds
SpecToImplIds (AbstractToConcreteIdMaps -> SpecToImplIds)
-> AbstractToConcreteIdMaps -> SpecToImplIds
forall a b. (a -> b) -> a -> b
$ AbstractToConcreteIdMaps :: Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
Spec.Test.AbstractToConcreteIdMaps {
      transactionIds :: Map TxId TxId
transactionIds = TxId -> TxId -> Map TxId TxId
forall k a. k -> a -> Map k a
Map.singleton (Tx -> TxId
specTxId Tx
spec) (ATxAux ByteString -> TxId
byronIdTx ATxAux ByteString
impl)
    , proposalIds :: Map UpId UpId
proposalIds    = Map UpId UpId
forall k a. Map k a
Map.empty
    }
  where
    specTxId :: Spec.Tx -> Spec.TxId
    specTxId :: Tx -> TxId
specTxId = TxBody -> TxId
Spec.txid (TxBody -> TxId) -> (Tx -> TxBody) -> Tx -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxBody
Spec.body

{-------------------------------------------------------------------------------
  Bridge
-------------------------------------------------------------------------------}

-- | Bridge the gap between the Byron implementation and specification
--
-- The relation between the Byron implementation and specification for the
-- /linear/ case is tested in the Byron implementation itself, specifically
-- in 'ts_prop_generatedChainsAreValidated'. The main goal of the consensus
-- DualByron tests is to lift these tests to the general consensus setting,
-- where time is not linear but branching.
--
-- In the linear case, the tests maintain some state linking the spec and
-- the implementation. In the consensus case, this state cannot be maintained
-- like this, and so it has to become part of transactions, blocks, and the
-- ledger state itself.
data ByronSpecBridge = ByronSpecBridge {
      -- | Map between keys
      --
      -- Some observations:
      --
      -- * The abstract chain environment contains a set of allowed delegators
      --   (of type @Set VKeyGenesis@), which gets translated to
      --   'gdGenesisKeyHashes' (of type @Set Common.KeyHash@) in the concrete
      --   genesis config.
      --
      -- * During the translation from abstract blocks to concrete blocks, the
      --   'VKey' of the block is translated to a concrete 'SigningKey' (as well
      --   as a 'VerificationKey') in 'elaborateKeyPair'.
      --
      -- * Although this translation is deterministic, it doesn't have an
      --   easily definable inverse. For this reason, we maintain an opposite
      --   mapping as part of the ledger state.
      ByronSpecBridge -> Map (PBftVerKeyHash PBftByronCrypto) VKey
toSpecKeys :: Map (PBftVerKeyHash PBftByronCrypto) Spec.VKey

      -- | Mapping between abstract and concrete Ids
      --
      -- We need to maintain this mapping so that we can use the abstract state
      -- generators and then elaborate to concrete values.
    , ByronSpecBridge -> SpecToImplIds
toImplIds  :: SpecToImplIds
    }
  deriving (Int -> ByronSpecBridge -> ShowS
[ByronSpecBridge] -> ShowS
ByronSpecBridge -> String
(Int -> ByronSpecBridge -> ShowS)
-> (ByronSpecBridge -> String)
-> ([ByronSpecBridge] -> ShowS)
-> Show ByronSpecBridge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByronSpecBridge] -> ShowS
$cshowList :: [ByronSpecBridge] -> ShowS
show :: ByronSpecBridge -> String
$cshow :: ByronSpecBridge -> String
showsPrec :: Int -> ByronSpecBridge -> ShowS
$cshowsPrec :: Int -> ByronSpecBridge -> ShowS
Show, ByronSpecBridge -> ByronSpecBridge -> Bool
(ByronSpecBridge -> ByronSpecBridge -> Bool)
-> (ByronSpecBridge -> ByronSpecBridge -> Bool)
-> Eq ByronSpecBridge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ByronSpecBridge -> ByronSpecBridge -> Bool
$c/= :: ByronSpecBridge -> ByronSpecBridge -> Bool
== :: ByronSpecBridge -> ByronSpecBridge -> Bool
$c== :: ByronSpecBridge -> ByronSpecBridge -> Bool
Eq, (forall x. ByronSpecBridge -> Rep ByronSpecBridge x)
-> (forall x. Rep ByronSpecBridge x -> ByronSpecBridge)
-> Generic ByronSpecBridge
forall x. Rep ByronSpecBridge x -> ByronSpecBridge
forall x. ByronSpecBridge -> Rep ByronSpecBridge x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ByronSpecBridge x -> ByronSpecBridge
$cfrom :: forall x. ByronSpecBridge -> Rep ByronSpecBridge x
Generic, [ByronSpecBridge] -> Encoding
ByronSpecBridge -> Encoding
(ByronSpecBridge -> Encoding)
-> (forall s. Decoder s ByronSpecBridge)
-> ([ByronSpecBridge] -> Encoding)
-> (forall s. Decoder s [ByronSpecBridge])
-> Serialise ByronSpecBridge
forall s. Decoder s [ByronSpecBridge]
forall s. Decoder s ByronSpecBridge
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
decodeList :: Decoder s [ByronSpecBridge]
$cdecodeList :: forall s. Decoder s [ByronSpecBridge]
encodeList :: [ByronSpecBridge] -> Encoding
$cencodeList :: [ByronSpecBridge] -> Encoding
decode :: Decoder s ByronSpecBridge
$cdecode :: forall s. Decoder s ByronSpecBridge
encode :: ByronSpecBridge -> Encoding
$cencode :: ByronSpecBridge -> Encoding
Serialise)

instance Bridge ByronBlock ByronSpecBlock where
  type BridgeLedger ByronBlock ByronSpecBlock = ByronSpecBridge
  type BridgeBlock  ByronBlock ByronSpecBlock = SpecToImplIds
  type BridgeTx     ByronBlock ByronSpecBlock = SpecToImplIds

  -- TODO: Once we generate delegation certificates,
  -- we should update 'toSpecKeys' also,

  updateBridgeWithBlock :: DualBlock ByronBlock ByronSpecBlock
-> BridgeLedger ByronBlock ByronSpecBlock
-> BridgeLedger ByronBlock ByronSpecBlock
updateBridgeWithBlock DualBlock ByronBlock ByronSpecBlock
block BridgeLedger ByronBlock ByronSpecBlock
bridge = BridgeLedger ByronBlock ByronSpecBlock
ByronSpecBridge
bridge {
        toImplIds :: SpecToImplIds
toImplIds = ByronSpecBridge -> SpecToImplIds
toImplIds BridgeLedger ByronBlock ByronSpecBlock
ByronSpecBridge
bridge SpecToImplIds -> SpecToImplIds -> SpecToImplIds
forall a. Semigroup a => a -> a -> a
<> DualBlock ByronBlock ByronSpecBlock
-> BridgeBlock ByronBlock ByronSpecBlock
forall m a. DualBlock m a -> BridgeBlock m a
dualBlockBridge DualBlock ByronBlock ByronSpecBlock
block
      }

  updateBridgeWithTx :: Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
-> BridgeLedger ByronBlock ByronSpecBlock
-> BridgeLedger ByronBlock ByronSpecBlock
updateBridgeWithTx Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
genTx BridgeLedger ByronBlock ByronSpecBlock
bridge = BridgeLedger ByronBlock ByronSpecBlock
ByronSpecBridge
bridge {
        toImplIds :: SpecToImplIds
toImplIds = ByronSpecBridge -> SpecToImplIds
toImplIds BridgeLedger ByronBlock ByronSpecBlock
ByronSpecBridge
bridge SpecToImplIds -> SpecToImplIds -> SpecToImplIds
forall a. Semigroup a => a -> a -> a
<> Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
-> BridgeTx ByronBlock ByronSpecBlock
forall m a. Validated (GenTx (DualBlock m a)) -> BridgeTx m a
vDualGenTxBridge Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
genTx
      }

{-------------------------------------------------------------------------------
  Bridge initialization
-------------------------------------------------------------------------------}

initByronSpecBridge :: ByronSpecGenesis
                    -> Map Spec.TxId Impl.TxId
                    -- ^ Mapping for the transaction in the initial UTxO
                    -> ByronSpecBridge
initByronSpecBridge :: ByronSpecGenesis -> Map TxId TxId -> ByronSpecBridge
initByronSpecBridge ByronSpecGenesis{Natural
Set VKeyGenesis
BlockCount
UTxO
PParams
byronSpecGenesisDelegators :: ByronSpecGenesis -> Set VKeyGenesis
byronSpecGenesisInitUtxo :: ByronSpecGenesis -> UTxO
byronSpecGenesisInitPParams :: ByronSpecGenesis -> PParams
byronSpecGenesisSecurityParam :: ByronSpecGenesis -> BlockCount
byronSpecGenesisSlotLength :: ByronSpecGenesis -> Natural
byronSpecGenesisSlotLength :: Natural
byronSpecGenesisSecurityParam :: BlockCount
byronSpecGenesisInitPParams :: PParams
byronSpecGenesisInitUtxo :: UTxO
byronSpecGenesisDelegators :: Set VKeyGenesis
..} Map TxId TxId
txIdMap = ByronSpecBridge :: Map (PBftVerKeyHash PBftByronCrypto) VKey
-> SpecToImplIds -> ByronSpecBridge
ByronSpecBridge {
      toSpecKeys :: Map (PBftVerKeyHash PBftByronCrypto) VKey
toSpecKeys = [(KeyHash, VKey)] -> Map KeyHash VKey
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(KeyHash, VKey)] -> Map KeyHash VKey)
-> [(KeyHash, VKey)] -> Map KeyHash VKey
forall a b. (a -> b) -> a -> b
$ (VKeyGenesis -> (KeyHash, VKey))
-> [VKeyGenesis] -> [(KeyHash, VKey)]
forall a b. (a -> b) -> [a] -> [b]
map VKeyGenesis -> (PBftVerKeyHash PBftByronCrypto, VKey)
VKeyGenesis -> (KeyHash, VKey)
mapKey ([VKeyGenesis] -> [(KeyHash, VKey)])
-> [VKeyGenesis] -> [(KeyHash, VKey)]
forall a b. (a -> b) -> a -> b
$
                     Set VKeyGenesis -> [VKeyGenesis]
forall a. Set a -> [a]
Set.toList Set VKeyGenesis
byronSpecGenesisDelegators
    , toImplIds :: SpecToImplIds
toImplIds  = AbstractToConcreteIdMaps -> SpecToImplIds
SpecToImplIds AbstractToConcreteIdMaps :: Map TxId TxId -> Map UpId UpId -> AbstractToConcreteIdMaps
Spec.Test.AbstractToConcreteIdMaps {
                       transactionIds :: Map TxId TxId
transactionIds = Map TxId TxId
txIdMap
                     , proposalIds :: Map UpId UpId
proposalIds    = Map UpId UpId
forall k a. Map k a
Map.empty
                     }
    }
  where
    -- The abstract spec maps the allowed delegators to themselves initially
    mapKey :: Spec.VKeyGenesis -> (PBftVerKeyHash PBftByronCrypto, Spec.VKey)
    mapKey :: VKeyGenesis -> (PBftVerKeyHash PBftByronCrypto, VKey)
mapKey (Spec.VKeyGenesis VKey
vkey) = (
          VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> PBftVerKeyHash PBftByronCrypto
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
hashVerKey (VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
 -> PBftVerKeyHash PBftByronCrypto)
-> VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> PBftVerKeyHash PBftByronCrypto
forall a b. (a -> b) -> a -> b
$ VerificationKey -> VerKeyDSIGN ByronDSIGN
VerKeyByronDSIGN (VKey -> VerificationKey
Spec.Test.elaborateVKey VKey
vkey)
        , VKey
vkey
        )

{-------------------------------------------------------------------------------
  Using the bridge
-------------------------------------------------------------------------------}

-- | Translate issuer key
--
-- We get a proof from PBFT that we are the leader, including a signing key (of
-- type 'SigningKey'). In order to produce the corresponding abstract block, we
-- need a 'VKey'.
bridgeToSpecKey :: DualByronBridge
                -> PBftVerKeyHash PBftByronCrypto -> Spec.VKey
bridgeToSpecKey :: BridgeLedger ByronBlock ByronSpecBlock
-> PBftVerKeyHash PBftByronCrypto -> VKey
bridgeToSpecKey ByronSpecBridge{..} PBftVerKeyHash PBftByronCrypto
keyHash =
    case KeyHash -> Map KeyHash VKey -> Maybe VKey
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PBftVerKeyHash PBftByronCrypto
KeyHash
keyHash Map (PBftVerKeyHash PBftByronCrypto) VKey
Map KeyHash VKey
toSpecKeys of
      Just VKey
vkey -> VKey
vkey
      Maybe VKey
Nothing   -> String -> VKey
forall a. HasCallStack => String -> a
error (String -> VKey) -> String -> VKey
forall a b. (a -> b) -> a -> b
$ String
"toSpecKey: unknown key " String -> ShowS
forall a. [a] -> [a] -> [a]
++ KeyHash -> String
forall a. Show a => a -> String
show PBftVerKeyHash PBftByronCrypto
KeyHash
keyHash

bridgeTransactionIds :: DualByronBridge -> Map Spec.TxId Impl.TxId
bridgeTransactionIds :: BridgeLedger ByronBlock ByronSpecBlock -> Map TxId TxId
bridgeTransactionIds = AbstractToConcreteIdMaps -> Map TxId TxId
Spec.Test.transactionIds
                     (AbstractToConcreteIdMaps -> Map TxId TxId)
-> (ByronSpecBridge -> AbstractToConcreteIdMaps)
-> ByronSpecBridge
-> Map TxId TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecToImplIds -> AbstractToConcreteIdMaps
getSpecToImplIds
                     (SpecToImplIds -> AbstractToConcreteIdMaps)
-> (ByronSpecBridge -> SpecToImplIds)
-> ByronSpecBridge
-> AbstractToConcreteIdMaps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByronSpecBridge -> SpecToImplIds
toImplIds

{-------------------------------------------------------------------------------
  Block forging
-------------------------------------------------------------------------------}

forgeDualByronBlock
  :: HasCallStack
  => TopLevelConfig DualByronBlock
  -> BlockNo                              -- ^ Current block number
  -> SlotNo                               -- ^ Current slot number
  -> TickedLedgerState DualByronBlock     -- ^ Ledger
  -> [Validated (GenTx DualByronBlock)]   -- ^ Txs to add in the block
  -> PBftIsLeader PBftByronCrypto         -- ^ Leader proof ('IsLeader')
  -> DualByronBlock
forgeDualByronBlock :: TopLevelConfig (DualBlock ByronBlock ByronSpecBlock)
-> BlockNo
-> SlotNo
-> TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
-> [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
-> PBftIsLeader PBftByronCrypto
-> DualBlock ByronBlock ByronSpecBlock
forgeDualByronBlock TopLevelConfig (DualBlock ByronBlock ByronSpecBlock)
cfg BlockNo
curBlockNo SlotNo
curSlotNo TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
tickedLedger [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
vtxs PBftIsLeader PBftByronCrypto
isLeader =
    -- NOTE: We do not /elaborate/ the real Byron block from the spec one, but
    -- instead we /forge/ it. This is important, because we want to test that
    -- codepath. This does mean that we do not get any kind of "bridge" between
    -- the two blocks (which we would have gotten if we would have elaborated
    -- the block instead). Fortunately, this is okay, since the bridge for the
    -- block can be computed from the bridge information of all of the txs.
    DualBlock :: forall m a. m -> Maybe a -> BridgeBlock m a -> DualBlock m a
DualBlock {
        dualBlockMain :: ByronBlock
dualBlockMain   = ByronBlock
main
      , dualBlockAux :: Maybe ByronSpecBlock
dualBlockAux    = ByronSpecBlock -> Maybe ByronSpecBlock
forall a. a -> Maybe a
Just ByronSpecBlock
aux
      , dualBlockBridge :: BridgeBlock ByronBlock ByronSpecBlock
dualBlockBridge = [SpecToImplIds] -> SpecToImplIds
forall a. Monoid a => [a] -> a
mconcat ([SpecToImplIds] -> SpecToImplIds)
-> [SpecToImplIds] -> SpecToImplIds
forall a b. (a -> b) -> a -> b
$ (Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
 -> SpecToImplIds)
-> [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
-> [SpecToImplIds]
forall a b. (a -> b) -> [a] -> [b]
map Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
-> SpecToImplIds
forall m a. Validated (GenTx (DualBlock m a)) -> BridgeTx m a
vDualGenTxBridge [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
vtxs
      }
  where
    main :: ByronBlock
    main :: ByronBlock
main = HasCallStack =>
TopLevelConfig ByronBlock
-> TxOverrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
TopLevelConfig ByronBlock
-> TxOverrides ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock
-> [Validated (GenTx ByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> ByronBlock
forgeByronBlock
             (TopLevelConfig (DualBlock ByronBlock ByronSpecBlock)
-> TopLevelConfig ByronBlock
forall m a. TopLevelConfig (DualBlock m a) -> TopLevelConfig m
dualTopLevelConfigMain TopLevelConfig (DualBlock ByronBlock ByronSpecBlock)
cfg)
             (TxMeasure ByronBlock -> TxOverrides ByronBlock
forall blk. TxMeasure blk -> TxOverrides blk
Mempool.mkOverrides TxMeasure ByronBlock
forall a. BoundedMeasure a => a
Mempool.noOverridesMeasure)
             BlockNo
curBlockNo
             SlotNo
curSlotNo
             (TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
-> TickedLedgerState ByronBlock
forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateMain TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
tickedLedger)
             ((Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
 -> Validated (GenTx ByronBlock))
-> [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
-> [Validated (GenTx ByronBlock)]
forall a b. (a -> b) -> [a] -> [b]
map Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
-> Validated (GenTx ByronBlock)
forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx m)
vDualGenTxMain [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
vtxs)
             PBftIsLeader PBftByronCrypto
isLeader

    aux :: ByronSpecBlock
    aux :: ByronSpecBlock
aux = BlockNo
-> SlotNo
-> Ticked (LedgerState ByronSpecBlock)
-> [Validated (GenTx ByronSpecBlock)]
-> VKey
-> ByronSpecBlock
forgeByronSpecBlock
            BlockNo
curBlockNo
            SlotNo
curSlotNo
            (TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
-> Ticked (LedgerState ByronSpecBlock)
forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateAux TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
tickedLedger)
            ((Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
 -> Validated (GenTx ByronSpecBlock))
-> [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
-> [Validated (GenTx ByronSpecBlock)]
forall a b. (a -> b) -> [a] -> [b]
map Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))
-> Validated (GenTx ByronSpecBlock)
forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx a)
vDualGenTxAux [Validated (GenTx (DualBlock ByronBlock ByronSpecBlock))]
vtxs)
            (BridgeLedger ByronBlock ByronSpecBlock
-> PBftVerKeyHash PBftByronCrypto -> VKey
bridgeToSpecKey
               (TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
-> BridgeLedger ByronBlock ByronSpecBlock
forall m a.
Ticked (LedgerState (DualBlock m a)) -> BridgeLedger m a
tickedDualLedgerStateBridge TickedLedgerState (DualBlock ByronBlock ByronSpecBlock)
tickedLedger)
               (VerKeyDSIGN ByronDSIGN -> KeyHash
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
hashVerKey (VerKeyDSIGN ByronDSIGN -> KeyHash)
-> (PBftIsLeader PBftByronCrypto -> VerKeyDSIGN ByronDSIGN)
-> PBftIsLeader PBftByronCrypto
-> KeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyDSIGN ByronDSIGN -> VerKeyDSIGN ByronDSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN (SignKeyDSIGN ByronDSIGN -> VerKeyDSIGN ByronDSIGN)
-> (PBftIsLeader PBftByronCrypto -> SignKeyDSIGN ByronDSIGN)
-> PBftIsLeader PBftByronCrypto
-> VerKeyDSIGN ByronDSIGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PBftIsLeader PBftByronCrypto -> SignKeyDSIGN ByronDSIGN
forall c. PBftIsLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderSignKey (PBftIsLeader PBftByronCrypto -> KeyHash)
-> PBftIsLeader PBftByronCrypto -> KeyHash
forall a b. (a -> b) -> a -> b
$ PBftIsLeader PBftByronCrypto
isLeader))