{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.ThreadNet.Infra.Byron.TrackUpdates
  ( ProtocolVersionUpdateLabel (..)
  , SoftwareVersionUpdateLabel (..)
  , mkProtocolByronAndHardForkTxs
  , mkUpdateLabels
  ) where

import qualified Cardano.Chain.Block as Block
import qualified Cardano.Chain.Byron.API as ByronAPI
import qualified Cardano.Chain.Genesis as Genesis
import qualified Cardano.Chain.MempoolPayload as MempoolPayload
import Cardano.Chain.Slotting (EpochSlots (..), SlotNumber (..))
import qualified Cardano.Chain.Update as Update
import Cardano.Chain.Update.Proposal (AProposal)
import qualified Cardano.Chain.Update.Proposal as Proposal
import qualified Cardano.Chain.Update.Validation.Interface as Update
import qualified Cardano.Chain.Update.Validation.Registration as Registration
import Cardano.Chain.Update.Vote (AVote)
import qualified Cardano.Chain.Update.Vote as Vote
import qualified Cardano.Crypto as Crypto
import Cardano.Ledger.BaseTypes (unNonZero)
import Cardano.Ledger.Binary (ByteSpan, DecCBOR (..), EncCBOR (..))
import Control.Exception (assert)
import Control.Monad (guard)
import Data.ByteString (ByteString)
import Data.Coerce (coerce)
import Data.Functor.Identity
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word64)
import GHC.Stack (HasCallStack)
import Ouroboros.Consensus.Block
import qualified Ouroboros.Consensus.Byron.Crypto.DSIGN as Crypto
import Ouroboros.Consensus.Byron.Ledger (ByronBlock)
import qualified Ouroboros.Consensus.Byron.Ledger as Byron
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Tables (EmptyMK)
import Ouroboros.Consensus.Node.ProtocolInfo
  ( NumCoreNodes (..)
  , ProtocolInfo (..)
  )
import Ouroboros.Consensus.NodeId (CoreNodeId (..))
import Ouroboros.Consensus.Protocol.PBFT
import Test.ThreadNet.Infra.Byron.ProtocolInfo
import Test.ThreadNet.Network (TestNodeInitialization (..))
import qualified Test.ThreadNet.Ref.PBFT as Ref
import Test.ThreadNet.Util.NodeJoinPlan
import Test.ThreadNet.Util.NodeTopology
import Test.Util.Slots (NumSlots (..))

-- | The expectation and observation regarding whether the hard-fork proposal
-- successfully updated the protocol version
data ProtocolVersionUpdateLabel = ProtocolVersionUpdateLabel
  { ProtocolVersionUpdateLabel -> Bool
pvuObserved :: Bool
  -- ^ whether the proposed protocol version is adopted or not adopted by the
  -- end of the test
  , ProtocolVersionUpdateLabel -> Maybe Bool
pvuRequired :: Maybe Bool
  -- ^ @Just b@ indicates whether the final chains must have adopted or must
  -- have not adopted the proposed protocol version. @Nothing@ means there is
  -- no requirement.
  }
  deriving Int -> ProtocolVersionUpdateLabel -> ShowS
[ProtocolVersionUpdateLabel] -> ShowS
ProtocolVersionUpdateLabel -> String
(Int -> ProtocolVersionUpdateLabel -> ShowS)
-> (ProtocolVersionUpdateLabel -> String)
-> ([ProtocolVersionUpdateLabel] -> ShowS)
-> Show ProtocolVersionUpdateLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProtocolVersionUpdateLabel -> ShowS
showsPrec :: Int -> ProtocolVersionUpdateLabel -> ShowS
$cshow :: ProtocolVersionUpdateLabel -> String
show :: ProtocolVersionUpdateLabel -> String
$cshowList :: [ProtocolVersionUpdateLabel] -> ShowS
showList :: [ProtocolVersionUpdateLabel] -> ShowS
Show

-- | As 'ProtocolVersionUpdateLabel', but for software version updates
--
-- Note that software version updates are adopted sooner than and perhaps
-- independently of protocol version updates, even when they are introduced by
-- the same proposal transaction.
data SoftwareVersionUpdateLabel = SoftwareVersionUpdateLabel
  { SoftwareVersionUpdateLabel -> Bool
svuObserved :: Bool
  , SoftwareVersionUpdateLabel -> Maybe Bool
svuRequired :: Maybe Bool
  }
  deriving Int -> SoftwareVersionUpdateLabel -> ShowS
[SoftwareVersionUpdateLabel] -> ShowS
SoftwareVersionUpdateLabel -> String
(Int -> SoftwareVersionUpdateLabel -> ShowS)
-> (SoftwareVersionUpdateLabel -> String)
-> ([SoftwareVersionUpdateLabel] -> ShowS)
-> Show SoftwareVersionUpdateLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SoftwareVersionUpdateLabel -> ShowS
showsPrec :: Int -> SoftwareVersionUpdateLabel -> ShowS
$cshow :: SoftwareVersionUpdateLabel -> String
show :: SoftwareVersionUpdateLabel -> String
$cshowList :: [SoftwareVersionUpdateLabel] -> ShowS
showList :: [SoftwareVersionUpdateLabel] -> ShowS
Show

-- | Classify the a @QuickCheck@ test's input and output with respect to
-- whether the protocol\/software version should have been\/was updated
mkUpdateLabels ::
  PBftParams ->
  NumSlots ->
  Genesis.Config ->
  NodeJoinPlan ->
  NodeTopology ->
  Ref.Result ->
  -- | from 'nodeOutputFinalLedger'
  Byron.LedgerState ByronBlock EmptyMK ->
  (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
mkUpdateLabels :: PBftParams
-> NumSlots
-> Config
-> NodeJoinPlan
-> NodeTopology
-> Result
-> LedgerState ByronBlock EmptyMK
-> (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
mkUpdateLabels
  PBftParams
params
  NumSlots
numSlots
  Config
genesisConfig
  NodeJoinPlan
nodeJoinPlan
  NodeTopology
topology
  Result
result
  LedgerState ByronBlock EmptyMK
ldgr =
    (ProtocolVersionUpdateLabel
pvuLabel, SoftwareVersionUpdateLabel
svuLabel)
   where
    PBftParams{NumCoreNodes
pbftNumNodes :: NumCoreNodes
pbftNumNodes :: PBftParams -> NumCoreNodes
pbftNumNodes, SecurityParam
pbftSecurityParam :: SecurityParam
pbftSecurityParam :: PBftParams -> SecurityParam
pbftSecurityParam} = PBftParams
params

    -- the slot immediately after the end of the simulation
    sentinel :: SlotNumber
    sentinel :: SlotNumber
sentinel = Word64 -> SlotNumber
SlotNumber Word64
t
     where
      NumSlots Word64
t = NumSlots
numSlots

    -- a block forged in slot @s@ becomes immutable/stable in slot @s + twoK@
    -- according to the Byron Chain Density invariant
    twoK :: SlotNo
    twoK :: SlotNo
twoK = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
pbftSecurityParam)

    -- the number of slots in an epoch
    epochSlots :: SlotNo
    epochSlots :: SlotNo
epochSlots = EpochSlots -> SlotNo
forall a b. Coercible a b => a -> b
coerce (EpochSlots -> SlotNo) -> EpochSlots -> SlotNo
forall a b. (a -> b) -> a -> b
$ Config -> EpochSlots
Genesis.configEpochSlots Config
genesisConfig

    -- the protocol parameters
    --
    -- ASSUMPTION: These do not change during the test.
    pp0 :: Update.ProtocolParameters
    pp0 :: ProtocolParameters
pp0 = Config -> ProtocolParameters
Genesis.configProtocolParameters Config
genesisConfig

    -- how many votes/endorsements the proposal needs to gain
    quorum :: Word64
    quorum :: Word64
quorum =
      (\Word64
x -> Bool -> Word64 -> Word64
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0) Word64
x) (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$
        Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$
          Word8 -> ProtocolParameters -> Int
Update.upAdptThd (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) ProtocolParameters
pp0
     where
      NumCoreNodes Word64
n = NumCoreNodes
pbftNumNodes

    -- how many slots the proposal has to gain sufficient votes before it
    -- expires
    ttl :: SlotNo
    ttl :: SlotNo
ttl = SlotNumber -> SlotNo
forall a b. Coercible a b => a -> b
coerce (SlotNumber -> SlotNo) -> SlotNumber -> SlotNo
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> SlotNumber
Update.ppUpdateProposalTTL ProtocolParameters
pp0

    -- the first slot of the epoch after the epoch containing the given slot
    ebbSlotAfter :: SlotNo -> SlotNo
    ebbSlotAfter :: SlotNo -> SlotNo
ebbSlotAfter (SlotNo Word64
s) =
      Word64 -> SlotNo
SlotNo (Word64
denom Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
div Word64
s Word64
denom) SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
epochSlots
     where
      SlotNo Word64
denom = SlotNo
epochSlots

    finalState :: [Ref.Outcome] -> ProposalState
    finalState :: [Outcome] -> ProposalState
finalState [Outcome]
outcomes = ProposalState -> SlotNo -> [Outcome] -> ProposalState
go ProposalState
Proposing (Word64 -> SlotNo
SlotNo Word64
0) [Outcome]
outcomes

    -- compute the @Just@ case of 'pvuRequired' from the simulated outcomes
    go ::
      ProposalState ->
      -- \^ the state before the next outcome
      SlotNo ->
      -- \^ the slot described by the next outcome
      [Ref.Outcome] ->
      ProposalState
    go :: ProposalState -> SlotNo -> [Outcome] -> ProposalState
go !ProposalState
st !SlotNo
s = \case
      [] -> Bool -> ProposalState -> ProposalState
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (SlotNumber -> SlotNo
forall a b. Coercible a b => a -> b
coerce SlotNumber
sentinel SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
s) ProposalState
st
      Outcome
o : [Outcome]
os -> case Outcome
o of
        Outcome
Ref.Absent -> ProposalState -> ProposalState
continueWith ProposalState
st
        Outcome
Ref.Unable -> ProposalState -> ProposalState
continueWith ProposalState
st
        Outcome
Ref.Wasted -> ProposalState -> ProposalState
continueWith ProposalState
st
        Outcome
Ref.Nominal -> case ProposalState
st of
          -- the proposal is in this slot
          ProposalState
Proposing ->
            let
              -- if this leader just joined, it will forge before the
              -- proposal reaches its mempool, unless it's node 0
              lostRace :: Bool
lostRace =
                SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
leaderJoinSlot
                  Bool -> Bool -> Bool
&& CoreNodeId
leader CoreNodeId -> CoreNodeId -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64 -> CoreNodeId
CoreNodeId Word64
0
             in
              if Bool
lostRace
                then ProposalState -> ProposalState
continueWith ProposalState
st
                else
                  -- votes can be valid immediately and at least one should
                  -- also be in this block
                  ProposalState -> SlotNo -> [Outcome] -> ProposalState
go (SlotNo -> Set CoreNodeId -> ProposalState
Voting SlotNo
s Set CoreNodeId
forall a. Set a
Set.empty) SlotNo
s (Outcome
o Outcome -> [Outcome] -> [Outcome]
forall a. a -> [a] -> [a]
: [Outcome]
os)
          Voting SlotNo
proposalSlot Set CoreNodeId
votes ->
            let votesInTheNewBlock :: Set CoreNodeId
votesInTheNewBlock =
                  -- an exception to the rule: the proposal and c0's
                  -- own vote always has time to reach its mempool
                  (if CoreNodeId
leader CoreNodeId -> CoreNodeId -> Bool
forall a. Eq a => a -> a -> Bool
== CoreNodeId
c0 then CoreNodeId -> Set CoreNodeId -> Set CoreNodeId
forall a. Ord a => a -> Set a -> Set a
Set.insert CoreNodeId
c0 else Set CoreNodeId -> Set CoreNodeId
forall a. a -> a
id) (Set CoreNodeId -> Set CoreNodeId)
-> Set CoreNodeId -> Set CoreNodeId
forall a b. (a -> b) -> a -> b
$
                    -- if the leader is joining in this slot, then no
                    -- votes will reach its mempool before it forges:
                    -- other nodes' votes will be delayed via
                    -- communication and its own vote is not valid
                    -- because it will forge before its ledger/mempool
                    -- contains the proposal
                    if SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
leaderJoinSlot
                      then Set CoreNodeId
forall a. Set a
Set.empty
                      else
                        -- only votes from nodes that joined prior to this
                        -- slot can reach the leader's mempool before it
                        -- forges
                        Map CoreNodeId SlotNo -> Set CoreNodeId
forall k a. Map k a -> Set k
Map.keysSet (Map CoreNodeId SlotNo -> Set CoreNodeId)
-> Map CoreNodeId SlotNo -> Set CoreNodeId
forall a b. (a -> b) -> a -> b
$ (SlotNo -> Bool) -> Map CoreNodeId SlotNo -> Map CoreNodeId SlotNo
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
s) Map CoreNodeId SlotNo
m
                 where
                  NodeJoinPlan Map CoreNodeId SlotNo
m = NodeJoinPlan
nodeJoinPlan
                  c0 :: CoreNodeId
c0 = Word64 -> CoreNodeId
CoreNodeId Word64
0

                votes' :: Set CoreNodeId
votes' = Set CoreNodeId -> Set CoreNodeId -> Set CoreNodeId
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set CoreNodeId
votesInTheNewBlock Set CoreNodeId
votes
                confirmed :: Bool
confirmed = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Set CoreNodeId -> Int
forall a. Set a -> Int
Set.size Set CoreNodeId
votes') Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
quorum
                expired :: Bool
expired = SlotNo
proposalSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
ttl SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
s
             in if
                  -- TODO cardano-ledger-byron checks for quorum before it checks
                  -- for expiry, so we do mimick that here. But is that
                  -- correct?
                  | Bool
confirmed -> ProposalState -> ProposalState
continueWith (ProposalState -> ProposalState) -> ProposalState -> ProposalState
forall a b. (a -> b) -> a -> b
$ SlotNo -> Set CoreNodeId -> ProposalState
Endorsing SlotNo
s Set CoreNodeId
forall a. Set a
Set.empty
                  -- c0 will re-propose the same proposal again at the next
                  -- opportunity
                  | Bool
expired -> ProposalState -> ProposalState
continueWith (ProposalState -> ProposalState) -> ProposalState -> ProposalState
forall a b. (a -> b) -> a -> b
$ ProposalState
Proposing
                  | Bool
otherwise -> ProposalState -> ProposalState
continueWith (ProposalState -> ProposalState) -> ProposalState -> ProposalState
forall a b. (a -> b) -> a -> b
$ SlotNo -> Set CoreNodeId -> ProposalState
Voting SlotNo
proposalSlot Set CoreNodeId
votes'
          Endorsing SlotNo
finalVoteSlot Set CoreNodeId
ends ->
            ProposalState -> ProposalState
continueWith (ProposalState -> ProposalState) -> ProposalState -> ProposalState
forall a b. (a -> b) -> a -> b
$
              if SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
finalVoteSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
twoK
                then ProposalState
st -- ignore endorsements until final vote is stable
                else
                  let ends' :: Set CoreNodeId
ends' = CoreNodeId -> Set CoreNodeId -> Set CoreNodeId
forall a. Ord a => a -> Set a -> Set a
Set.insert (PBftParams -> SlotNo -> CoreNodeId
Ref.mkLeaderOf PBftParams
params SlotNo
s) Set CoreNodeId
ends
                   in if Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Set CoreNodeId -> Int
forall a. Set a -> Int
Set.size Set CoreNodeId
ends) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
quorum
                        then SlotNo -> Set CoreNodeId -> ProposalState
Endorsing SlotNo
finalVoteSlot Set CoreNodeId
ends'
                        else SlotNo -> ProposalState
Adopting SlotNo
s -- enough endorsements
          Adopting{} -> ProposalState -> ProposalState
continueWith ProposalState
st
       where
        leader :: CoreNodeId
leader = PBftParams -> SlotNo -> CoreNodeId
Ref.mkLeaderOf PBftParams
params SlotNo
s
        leaderJoinSlot :: SlotNo
leaderJoinSlot = (?callStack::CallStack) => NodeJoinPlan -> CoreNodeId -> SlotNo
NodeJoinPlan -> CoreNodeId -> SlotNo
coreNodeIdJoinSlot NodeJoinPlan
nodeJoinPlan CoreNodeId
leader

        continueWith :: ProposalState -> ProposalState
continueWith ProposalState
st' = ProposalState -> SlotNo -> [Outcome] -> ProposalState
go ProposalState
st' (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s) [Outcome]
os

    pvuLabel :: ProtocolVersionUpdateLabel
pvuLabel =
      ProtocolVersionUpdateLabel
        { pvuObserved :: Bool
pvuObserved =
            (ProtocolVersion -> ProtocolVersion -> Bool
forall a. Eq a => a -> a -> Bool
== ProtocolVersion
theProposedProtocolVersion) (ProtocolVersion -> Bool) -> ProtocolVersion -> Bool
forall a b. (a -> b) -> a -> b
$
              State -> ProtocolVersion
Update.adoptedProtocolVersion (State -> ProtocolVersion) -> State -> ProtocolVersion
forall a b. (a -> b) -> a -> b
$
                ChainValidationState -> State
Block.cvsUpdateState (ChainValidationState -> State) -> ChainValidationState -> State
forall a b. (a -> b) -> a -> b
$
                  -- tick the chain over into the slot after the final simulated slot
                  Config
-> SlotNumber -> ChainValidationState -> ChainValidationState
ByronAPI.applyChainTick Config
genesisConfig SlotNumber
sentinel (ChainValidationState -> ChainValidationState)
-> ChainValidationState -> ChainValidationState
forall a b. (a -> b) -> a -> b
$
                    LedgerState ByronBlock EmptyMK -> ChainValidationState
forall (mk :: MapKind).
LedgerState ByronBlock mk -> ChainValidationState
Byron.byronLedgerState LedgerState ByronBlock EmptyMK
ldgr
        , pvuRequired :: Maybe Bool
pvuRequired = case Result
result of
            -- 'Ref.Forked' means there's only 1-block chains, and that's not enough
            -- for a proposal to succeed
            Ref.Forked{} -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
            -- we wouldn't necessarily be able to anticipate when the last
            -- endorsement happens, so give up
            Ref.Nondeterministic{} -> Maybe Bool
forall a. Maybe a
Nothing
            Ref.Outcomes [Outcome]
outcomes -> do
              PBftParams -> NodeTopology -> Maybe ()
checkTopo PBftParams
params NodeTopology
topology
              Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ case [Outcome] -> ProposalState
finalState [Outcome]
outcomes of
                Proposing{} -> Bool
False
                Voting{} -> Bool
False
                Endorsing{} -> Bool
False
                Adopting SlotNo
finalEndorsementSlot ->
                  SlotNo -> SlotNo
ebbSlotAfter (SlotNo
finalEndorsementSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
twoK) SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
s
                 where
                  s :: SlotNo
s = SlotNumber -> SlotNo
forall a b. Coercible a b => a -> b
coerce SlotNumber
sentinel
        }

    svuLabel :: SoftwareVersionUpdateLabel
svuLabel =
      SoftwareVersionUpdateLabel
        { svuObserved :: Bool
svuObserved = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
            let nm :: ApplicationName
nm = SoftwareVersion -> ApplicationName
Update.svAppName SoftwareVersion
theProposedSoftwareVersion
            (Registration.ApplicationVersion vn _slot _metadata) <-
              ApplicationName
-> Map ApplicationName ApplicationVersion
-> Maybe ApplicationVersion
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ApplicationName
nm (Map ApplicationName ApplicationVersion
 -> Maybe ApplicationVersion)
-> Map ApplicationName ApplicationVersion
-> Maybe ApplicationVersion
forall a b. (a -> b) -> a -> b
$
                State -> Map ApplicationName ApplicationVersion
Update.appVersions (State -> Map ApplicationName ApplicationVersion)
-> State -> Map ApplicationName ApplicationVersion
forall a b. (a -> b) -> a -> b
$
                  ChainValidationState -> State
Block.cvsUpdateState (ChainValidationState -> State) -> ChainValidationState -> State
forall a b. (a -> b) -> a -> b
$
                    -- unlike for protocol version updates, there is no need to tick
                    -- since the passage of time isn't a prerequisite
                    LedgerState ByronBlock EmptyMK -> ChainValidationState
forall (mk :: MapKind).
LedgerState ByronBlock mk -> ChainValidationState
Byron.byronLedgerState LedgerState ByronBlock EmptyMK
ldgr
            pure $ vn == Update.svNumber theProposedSoftwareVersion
        , svuRequired :: Maybe Bool
svuRequired = case Result
result of
            -- 'Ref.Forked' means all blocks except perhaps the first were
            -- forged in the slot in which the forging node joined, which means
            -- nodes other than c0 never forged after receiving the proposal. A
            -- block forged by node c0 will have proposed and might have
            -- confirmed it (depending on quorum), but the other nodes will not
            -- have. This is very much a corner case, so we ignore it.
            Ref.Forked{} -> Maybe Bool
forall a. Maybe a
Nothing
            -- We wouldn't necessarily be able to anticipate if the proposal is
            -- confirmed or even in all of the final chains, so we ignore it.
            Ref.Nondeterministic{} -> Maybe Bool
forall a. Maybe a
Nothing
            Ref.Outcomes [Outcome]
outcomes -> do
              PBftParams -> NodeTopology -> Maybe ()
checkTopo PBftParams
params NodeTopology
topology
              Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ case [Outcome] -> ProposalState
finalState [Outcome]
outcomes of
                Proposing{} -> Bool
False
                Voting{} -> Bool
False
                Endorsing{} -> Bool
True
                Adopting{} -> Bool
True
        }

-- if the topology is not mesh, then some assumptions in 'finalState' about
-- races maybe be wrong
--
-- In particular, if the proposal is already on the chain, and the leader of
-- the next slot, call it node L, is joining and is only directly connected to
-- other nodes that are also joining, then those other node's votes will not
-- reach L's mempool before it forges in the next slot. In fact, those votes
-- will arrive to node L via TxSub during the current slot but /before/ the
-- block containing the proposal does, so node L's mempool will reject the
-- votes as invalid. The votes are not resent (at least not before node L
-- leads).
checkTopo :: PBftParams -> NodeTopology -> Maybe ()
checkTopo :: PBftParams -> NodeTopology -> Maybe ()
checkTopo PBftParams
params NodeTopology
topology = do
  let PBftParams{NumCoreNodes
pbftNumNodes :: PBftParams -> NumCoreNodes
pbftNumNodes :: NumCoreNodes
pbftNumNodes} = PBftParams
params
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ NodeTopology
topology NodeTopology -> NodeTopology -> Bool
forall a. Eq a => a -> a -> Bool
== NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
pbftNumNodes

-- | The state of a proposal within a linear timeline
data ProposalState
  = -- | submitting the proposal (possibly not for the first time, if it has
    -- previously expired)
    Proposing
  | -- | accumulating sufficient votes
    --
    -- The slot is when the proposal was submitted; it might expire during
    -- voting. The set is who has voted.
    Voting !SlotNo !(Set CoreNodeId)
  | -- | accumulating sufficient endorsements
    --
    -- The slot is when the first sufficient vote was submitted. The set is the
    -- endorsements seen so far.
    Endorsing !SlotNo !(Set CoreNodeId)
  | -- | waiting for epoch transition
    --
    -- The slot is when the first sufficient endorsement was submitted.
    Adopting !SlotNo
  deriving Int -> ProposalState -> ShowS
[ProposalState] -> ShowS
ProposalState -> String
(Int -> ProposalState -> ShowS)
-> (ProposalState -> String)
-> ([ProposalState] -> ShowS)
-> Show ProposalState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProposalState -> ShowS
showsPrec :: Int -> ProposalState -> ShowS
$cshow :: ProposalState -> String
show :: ProposalState -> String
$cshowList :: [ProposalState] -> ShowS
showList :: [ProposalState] -> ShowS
Show

{-------------------------------------------------------------------------------
  ProtocolVersion update proposals
-------------------------------------------------------------------------------}

-- | The protocol info for a node as well as some initial transactions
--
-- The transactions implement a smoke test for the hard-fork from Byron to
-- Shelley. See PR #1741 for details on how that hard-fork will work. The key
-- fact is that last thing the nodes will ever do while running the Byron
-- protocol is adopt a specific (but as of yet to-be-determined) protocol
-- version. So this smoke test ensures that the nodes can in fact adopt a new
-- protocol version.
--
-- Adopting a new protocol version requires four kinds of event in Byron.
-- Again, see PR #1741 for more details.
--
--  * Proposal transaction. A protocol parameter update proposal transaction
--    makes it onto the chain (it doesn't have to actually change any
--    parameters, just increase the protocol version). Proposals are
--    'MempoolPayload.MempoolUpdateProposal' transactions; one is included in
--    the return value of this function. In the smoke test, we immediately and
--    repeatedly throughout the test add the proposal to @CoreNodeId 0@'s
--    mempool; this seems realistic.
--
--  * Vote transactions. A sufficient number of nodes (@floor (0.6 *
--    'pbftNumNodes')@ as of this writing) must vote for the proposal. Votes
--    are 'MempoolPayload.MempoolUpdateVote' transactions; one per node is
--    included in the return value of this function. In the smoke test, we
--    immediately and repeatedly throughout the test add each node's vote to
--    its own mempool; this seems realistic.
--
--  * Endorsement header field. After enough votes are 2k slots old, a
--    sufficient number of nodes (@floor (0.6 * 'pbftNumNodes')@ as of this
--    writing) must then endorse the proposal. Endorsements are not
--    transactions. Instead, every Byron header includes a field that specifies
--    a protocol version to endorse. At a particular stage of a corresponding
--    proposal's lifetime, that field constitutes an endorsement. At all other
--    times, it is essentially ignored. In the smoke test, we take advantage of
--    that to avoid having to restart our nodes: the nodes' initial
--    configuration causes them to immediately and always attempt to endorse
--    the proposed protocol version; this seems only slightly unrealistic.
--
--  * Epoch transition. After enough endorsements are 2k slots old, the
--    protocol version will be adopted at the next epoch transition, unless
--    something else prevents it. In the smoke test, we check the validation
--    state of the final chains for the new protocol version when we detect no
--    mitigating circumstances, such as the test not even being scheduled to
--    reach the second epoch.
mkProtocolByronAndHardForkTxs ::
  forall m.
  (Monad m, HasCallStack) =>
  PBftParams ->
  CoreNodeId ->
  Genesis.Config ->
  Genesis.GeneratedSecrets ->
  -- | the protocol version that triggers the hard fork
  Update.ProtocolVersion ->
  TestNodeInitialization m ByronBlock
mkProtocolByronAndHardForkTxs :: forall (m :: * -> *).
(Monad m, ?callStack::CallStack) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> TestNodeInitialization m ByronBlock
mkProtocolByronAndHardForkTxs
  PBftParams
params
  CoreNodeId
cid
  Config
genesisConfig
  GeneratedSecrets
genesisSecrets
  ProtocolVersion
propPV =
    TestNodeInitialization
      { tniCrucialTxs :: [GenTx ByronBlock]
tniCrucialTxs = [GenTx ByronBlock]
proposals [GenTx ByronBlock] -> [GenTx ByronBlock] -> [GenTx ByronBlock]
forall a. [a] -> [a] -> [a]
++ [GenTx ByronBlock]
votes
      , tniProtocolInfo :: ProtocolInfo ByronBlock
tniProtocolInfo = ProtocolInfo ByronBlock
pInfo
      , tniBlockForging :: m [BlockForging m ByronBlock]
tniBlockForging = [BlockForging m ByronBlock] -> m [BlockForging m ByronBlock]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [BlockForging m ByronBlock]
blockForging
      }
   where
    ProtocolInfo{TopLevelConfig ByronBlock
pInfoConfig :: TopLevelConfig ByronBlock
pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig} = ProtocolInfo ByronBlock
pInfo
    bcfg :: BlockConfig ByronBlock
bcfg = TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig ByronBlock
pInfoConfig

    pInfo :: ProtocolInfo ByronBlock
    blockForging :: [BlockForging m ByronBlock]
    opKey :: Crypto.SigningKey
    (ProtocolInfo ByronBlock
pInfo, [BlockForging m ByronBlock]
blockForging, Crypto.SignKeyByronDSIGN SigningKey
opKey) =
      PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> (ProtocolInfo ByronBlock, [BlockForging m ByronBlock],
    SignKeyDSIGN ByronDSIGN)
forall (m :: * -> *).
(Monad m, ?callStack::CallStack) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> (ProtocolInfo ByronBlock, [BlockForging m ByronBlock],
    SignKeyDSIGN ByronDSIGN)
mkProtocolByron PBftParams
params CoreNodeId
cid Config
genesisConfig GeneratedSecrets
genesisSecrets

    proposals :: [Byron.GenTx ByronBlock]
    proposals :: [GenTx ByronBlock]
proposals =
      if CoreNodeId
cid CoreNodeId -> CoreNodeId -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64 -> CoreNodeId
CoreNodeId Word64
0
        then []
        else
          (GenTx ByronBlock -> [GenTx ByronBlock] -> [GenTx ByronBlock]
forall a. a -> [a] -> [a]
: []) (GenTx ByronBlock -> [GenTx ByronBlock])
-> GenTx ByronBlock -> [GenTx ByronBlock]
forall a b. (a -> b) -> a -> b
$
            AMempoolPayload ByteString -> GenTx ByronBlock
Byron.fromMempoolPayload (AMempoolPayload ByteString -> GenTx ByronBlock)
-> AMempoolPayload ByteString -> GenTx ByronBlock
forall a b. (a -> b) -> a -> b
$
              AProposal ByteString -> AMempoolPayload ByteString
forall a. AProposal a -> AMempoolPayload a
MempoolPayload.MempoolUpdateProposal AProposal ByteString
proposal

    votes :: [Byron.GenTx ByronBlock]
    votes :: [GenTx ByronBlock]
votes =
      (GenTx ByronBlock -> [GenTx ByronBlock] -> [GenTx ByronBlock]
forall a. a -> [a] -> [a]
: []) (GenTx ByronBlock -> [GenTx ByronBlock])
-> GenTx ByronBlock -> [GenTx ByronBlock]
forall a b. (a -> b) -> a -> b
$
        AMempoolPayload ByteString -> GenTx ByronBlock
Byron.fromMempoolPayload (AMempoolPayload ByteString -> GenTx ByronBlock)
-> AMempoolPayload ByteString -> GenTx ByronBlock
forall a b. (a -> b) -> a -> b
$
          AVote ByteString -> AMempoolPayload ByteString
forall a. AVote a -> AMempoolPayload a
MempoolPayload.MempoolUpdateVote AVote ByteString
vote

    vote :: AVote ByteString
    vote :: AVote ByteString
vote =
      AVote () -> AVote ByteString
forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
loopbackAnnotations (AVote () -> AVote ByteString) -> AVote () -> AVote ByteString
forall a b. (a -> b) -> a -> b
$
        -- signed by delegate SK
        ProtocolMagicId -> UpId -> Bool -> SafeSigner -> AVote ()
Vote.signVote
          (BlockConfig ByronBlock -> ProtocolMagicId
Byron.byronProtocolMagicId BlockConfig ByronBlock
bcfg)
          (AProposal ByteString -> UpId
Update.recoverUpId AProposal ByteString
proposal)
          Bool
True -- the serialization hardwires this value anyway
          (SigningKey -> SafeSigner
Crypto.noPassSafeSigner SigningKey
opKey)

    proposal :: AProposal ByteString
    proposal :: AProposal ByteString
proposal =
      AProposal () -> AProposal ByteString
forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
loopbackAnnotations (AProposal () -> AProposal ByteString)
-> AProposal () -> AProposal ByteString
forall a b. (a -> b) -> a -> b
$
        (?callStack::CallStack) =>
PBftParams
-> Config -> GeneratedSecrets -> ProtocolVersion -> AProposal ()
PBftParams
-> Config -> GeneratedSecrets -> ProtocolVersion -> AProposal ()
mkHardForkProposal PBftParams
params Config
genesisConfig GeneratedSecrets
genesisSecrets ProtocolVersion
propPV

-- | A protocol parameter update proposal that doesn't actually change any
-- parameter value but does propose 'theProposedProtocolVersion'
--
-- Without loss of generality, the proposal is signed by @'CoreNodeId' 0@.
mkHardForkProposal ::
  HasCallStack =>
  PBftParams ->
  Genesis.Config ->
  Genesis.GeneratedSecrets ->
  Update.ProtocolVersion ->
  AProposal ()
mkHardForkProposal :: (?callStack::CallStack) =>
PBftParams
-> Config -> GeneratedSecrets -> ProtocolVersion -> AProposal ()
mkHardForkProposal PBftParams
params Config
genesisConfig GeneratedSecrets
genesisSecrets ProtocolVersion
propPV =
  -- signed by delegate SK
  ProtocolMagicId -> ProposalBody -> SafeSigner -> AProposal ()
Proposal.signProposal
    (BlockConfig ByronBlock -> ProtocolMagicId
Byron.byronProtocolMagicId BlockConfig ByronBlock
bcfg)
    ProposalBody
propBody
    (SigningKey -> SafeSigner
Crypto.noPassSafeSigner SigningKey
opKey)
 where
  pInfo :: ProtocolInfo ByronBlock
  _blockForging :: [BlockForging Identity ByronBlock]
  opKey :: Crypto.SigningKey
  (ProtocolInfo ByronBlock
pInfo, [BlockForging Identity ByronBlock]
_blockForging, Crypto.SignKeyByronDSIGN SigningKey
opKey) =
    PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> (ProtocolInfo ByronBlock, [BlockForging Identity ByronBlock],
    SignKeyDSIGN ByronDSIGN)
forall (m :: * -> *).
(Monad m, ?callStack::CallStack) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> (ProtocolInfo ByronBlock, [BlockForging m ByronBlock],
    SignKeyDSIGN ByronDSIGN)
mkProtocolByron PBftParams
params (Word64 -> CoreNodeId
CoreNodeId Word64
0) Config
genesisConfig GeneratedSecrets
genesisSecrets

  ProtocolInfo{TopLevelConfig ByronBlock
pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig :: TopLevelConfig ByronBlock
pInfoConfig} = ProtocolInfo ByronBlock
pInfo
  bcfg :: BlockConfig ByronBlock
bcfg = TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig ByronBlock
pInfoConfig

  propBody :: Proposal.ProposalBody
  propBody :: ProposalBody
propBody =
    Proposal.ProposalBody
      { protocolVersion :: ProtocolVersion
Proposal.protocolVersion = ProtocolVersion
propPV
      , protocolParametersUpdate :: ProtocolParametersUpdate
Proposal.protocolParametersUpdate =
          Update.ProtocolParametersUpdate
            { ppuScriptVersion :: Maybe Word16
Update.ppuScriptVersion = Maybe Word16
forall a. Maybe a
Nothing
            , ppuSlotDuration :: Maybe Natural
Update.ppuSlotDuration = Maybe Natural
forall a. Maybe a
Nothing
            , ppuMaxBlockSize :: Maybe Natural
Update.ppuMaxBlockSize = Maybe Natural
forall a. Maybe a
Nothing
            , ppuMaxHeaderSize :: Maybe Natural
Update.ppuMaxHeaderSize = Maybe Natural
forall a. Maybe a
Nothing
            , ppuMaxTxSize :: Maybe Natural
Update.ppuMaxTxSize = Maybe Natural
forall a. Maybe a
Nothing
            , ppuMaxProposalSize :: Maybe Natural
Update.ppuMaxProposalSize = Maybe Natural
forall a. Maybe a
Nothing
            , ppuMpcThd :: Maybe LovelacePortion
Update.ppuMpcThd = Maybe LovelacePortion
forall a. Maybe a
Nothing
            , ppuHeavyDelThd :: Maybe LovelacePortion
Update.ppuHeavyDelThd = Maybe LovelacePortion
forall a. Maybe a
Nothing
            , ppuUpdateVoteThd :: Maybe LovelacePortion
Update.ppuUpdateVoteThd = Maybe LovelacePortion
forall a. Maybe a
Nothing
            , ppuUpdateProposalThd :: Maybe LovelacePortion
Update.ppuUpdateProposalThd = Maybe LovelacePortion
forall a. Maybe a
Nothing
            , ppuUpdateProposalTTL :: Maybe SlotNumber
Update.ppuUpdateProposalTTL = Maybe SlotNumber
forall a. Maybe a
Nothing
            , ppuSoftforkRule :: Maybe SoftforkRule
Update.ppuSoftforkRule = Maybe SoftforkRule
forall a. Maybe a
Nothing
            , ppuTxFeePolicy :: Maybe TxFeePolicy
Update.ppuTxFeePolicy = Maybe TxFeePolicy
forall a. Maybe a
Nothing
            , ppuUnlockStakeEpoch :: Maybe EpochNumber
Update.ppuUnlockStakeEpoch = Maybe EpochNumber
forall a. Maybe a
Nothing
            }
      , softwareVersion :: SoftwareVersion
Proposal.softwareVersion = SoftwareVersion
theProposedSoftwareVersion
      , metadata :: Metadata
Proposal.metadata = Metadata
forall k a. Map k a
Map.empty
      }

-- | Add the bytestring annotations that would be present if we were to
-- serialize the argument, send it to ourselves, receive it, and deserialize it
--
-- The mempool payloads require the serialized bytes as annotations. It's
-- tricky to get right, and this function lets use reuse the existing CBOR
-- instances.
loopbackAnnotations ::
  ( DecCBOR (f ByteSpan)
  , EncCBOR (f ())
  , Functor f
  ) =>
  f () ->
  f ByteString
loopbackAnnotations :: forall (f :: * -> *).
(DecCBOR (f ByteSpan), EncCBOR (f ()), Functor f) =>
f () -> f ByteString
loopbackAnnotations =
  (f () -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f () -> f ByteString
forall (f :: * -> *) a.
Functor f =>
(f a -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f a -> f ByteString
ByronAPI.reAnnotateUsing f () -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Decoder s (f ByteSpan)
forall s. Decoder s (f ByteSpan)
forall a s. DecCBOR a => Decoder s a
decCBOR