{-# LANGUAGE BangPatterns #-}
{-# 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.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.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
  -> Byron.LedgerState ByronBlock
     -- ^ from 'nodeOutputFinalLedger'
  -> (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
mkUpdateLabels :: PBftParams
-> NumSlots
-> Config
-> NodeJoinPlan
-> NodeTopology
-> Result
-> LedgerState ByronBlock
-> (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
mkUpdateLabels PBftParams
params NumSlots
numSlots Config
genesisConfig NodeJoinPlan
nodeJoinPlan NodeTopology
topology Result
result
  LedgerState ByronBlock
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
* SecurityParam -> 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
oOutcome -> [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 -> ChainValidationState
Byron.byronLedgerState LedgerState ByronBlock
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 NumSoftwareVersion
vn SlotNumber
_slot Metadata
_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 -> ChainValidationState
Byron.byronLedgerState LedgerState ByronBlock
ldgr
            Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ NumSoftwareVersion
vn NumSoftwareVersion -> NumSoftwareVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SoftwareVersion -> NumSoftwareVersion
Update.svNumber SoftwareVersion
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 =
    Proposing
    -- ^ submitting the proposal (possibly not for the first time, if it has
    -- previously expired)
  | Voting !SlotNo !(Set CoreNodeId)
    -- ^ accumulating sufficient votes
    --
    -- The slot is when the proposal was submitted; it might expire during
    -- voting. The set is who has voted.
  | Endorsing !SlotNo !(Set CoreNodeId)
    -- ^ accumulating sufficient endorsements
    --
    -- The slot is when the first sufficient vote was submitted. The set is the
    -- endorsements seen so far.
  | Adopting !SlotNo
    -- ^ waiting for epoch transition
    --
    -- The slot is when the first sufficient endorsement was submitted.
  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
  -> Update.ProtocolVersion
     -- ^ the protocol version that triggers the hard fork
  -> 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
      { $sel:protocolVersion:ProposalBody :: ProtocolVersion
Proposal.protocolVersion          = ProtocolVersion
propPV
      , $sel:protocolParametersUpdate:ProposalBody :: 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
        }
      , $sel:softwareVersion:ProposalBody :: SoftwareVersion
Proposal.softwareVersion          = SoftwareVersion
theProposedSoftwareVersion
      , $sel:metadata:ProposalBody :: 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