Skip to content
Permalink
Browse files

Merge #355

355: Implement UPIREG and UPIVOTE rules r=dnadales a=dnadales

Part of #189.

Co-authored-by: Damian Nadales <damian.nadales@iohk.io>
Co-authored-by: Michael Hueschen <michaelhueschen@gmail.com>
  • Loading branch information...
3 people committed Mar 15, 2019
2 parents 03cf720 + 32d1aa4 commit ad4596f3bc7cf91647857ff8c5bfb2439dc014cb
@@ -105,6 +105,7 @@ library
Cardano.Chain.Update.SystemTag
Cardano.Chain.Update.Undo
Cardano.Chain.Update.Validation.Endorsement
Cardano.Chain.Update.Validation.Interface
Cardano.Chain.Update.Validation.Registration
Cardano.Chain.Update.Validation.Voting
Cardano.Chain.Update.Vote
@@ -0,0 +1,167 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | Blockchain interface validation rules.
--
module Cardano.Chain.Update.Validation.Interface
( -- * Environment
Environment (..)
-- * State
, State (..)
-- *Error
, Error (..)
-- * Interface functions
, registerProposal
, registerVote
)
where

import Cardano.Prelude hiding (State)

import qualified Data.Map.Strict as M

import Cardano.Chain.Slotting (EpochIndex, FlatSlotId)
import Cardano.Chain.Common.StakeholderId (StakeholderId)

import Cardano.Chain.Update.ApplicationName (ApplicationName)
import Cardano.Chain.Update.ProtocolParameters (ProtocolParameters)
import Cardano.Chain.Update.ProtocolVersion (ProtocolVersion)
import Cardano.Chain.Update.SoftwareVersion
( NumSoftwareVersion
, SoftwareVersion
, svAppName
, svNumber
)
import qualified Cardano.Chain.Update.Validation.Registration as Registration
import qualified Cardano.Chain.Update.Validation.Voting as Voting
import Cardano.Chain.Update.Vote (UpId, AProposal, recoverUpId, AVote)
import Cardano.Crypto (ProtocolMagicId)

data TODO

data Environment = Environment
{ protocolMagic :: ProtocolMagicId
, currentEpoch :: !EpochIndex
, currentSlot :: !FlatSlotId
, delegationMap :: !(Map StakeholderId StakeholderId)
}

-- | Update interface state.
data State = State
{ prevEpoch :: !EpochIndex
-- ^ Previously seen epoch
, adoptedProtocolVersion :: !ProtocolVersion
, adoptedProtocolParams :: !ProtocolParameters
-- ^ Adopted protocol parameters
, futureAdopts :: !TODO -- We should take this from Cardano.Chain.Update.Validation.Endorsement
-- ^ Future protocol version adoptions
, appVersions :: !(Map ApplicationName (NumSoftwareVersion, FlatSlotId))
-- ^ Current application versions (by application name)
, registeredProtocolUpdateProposals :: !(Map UpId (ProtocolVersion, ProtocolParameters))
-- ^ Registered protocol update proposals
, registeredSoftwareUpdateProposals :: !(Map UpId SoftwareVersion)
-- ^ Registered software update proposals
, confirmedProposals :: !(Map UpId FlatSlotId)
-- ^ Confirmed update proposals
, proposalVotes :: !(Map UpId (Set StakeholderId))
-- ^ Update proposals votes
, proposalsEndorsements :: TODO -- We should take this from Cardano.Chain.Update.Validation.Endorsement
-- So this should be a @Set Endorsement@
-- ^ Update proposals endorsements
, proposalRegistrationSlot :: Map UpId FlatSlotId
-- ^ Slot at which an update proposal was registered
}

data Error
= Registration Registration.Error
| Voting Voting.Error

-- | Register an update proposal.
--
-- This corresponds to the @UPIREG@ rules in the spec.
registerProposal
:: MonadError Error m
=> Environment
-> State
-> AProposal ByteString
-> m State
registerProposal env st proposal = do
Registration.State rpus' raus' <-
Registration.registerProposal pm pv pps avs dms regSubSt proposal
`wrapError` Registration
pure $!
st { registeredProtocolUpdateProposals = rpus'
, registeredSoftwareUpdateProposals = raus'
, proposalRegistrationSlot = M.insert (recoverUpId proposal) currentSlot pws
}
where
Environment
{ protocolMagic = pm
, currentSlot
, delegationMap = dms
} = env

State
{ adoptedProtocolVersion = pv
, adoptedProtocolParams = pps
, appVersions = avs
, registeredProtocolUpdateProposals = rpus
, registeredSoftwareUpdateProposals = raus
, proposalRegistrationSlot = pws
} = st

regSubSt = Registration.State rpus raus

-- | Register a vote for the given proposal.
--
-- If the proposal gets enough confirmations after adding the given vote, then
-- it will get added to the set of confirmed proposals.
-- This corresponds to the @UPIVOTE@ rules in the spec.
--
registerVote
:: MonadError Error m
=> Environment
-> State
-> AVote ByteString
-> m State
registerVote env st vote = do
Voting.State vts' cps' <-
Voting.registerVoteWithConfirmation pm subEnv subSt vote
`wrapError` Voting
let
avsNew =
M.fromList $! [ (svAppName sv, (svNumber sv, sn))
| (pid, sv) <- M.toList raus
, pid `elem` M.keys cps'
]
pure $!
st { confirmedProposals = cps'
, proposalVotes = vts'
, appVersions = M.union avsNew avs
, registeredSoftwareUpdateProposals = M.withoutKeys raus (M.keysSet cps)
}
-- TODO: consider using the `Relation` instances from `fm-ledger-rules` (see `Ledger.Core`)

where

Environment
{ protocolMagic = pm
, currentSlot = sn
, delegationMap = dms
} = env

State
{ adoptedProtocolParams = pps
, proposalRegistrationSlot
, proposalVotes = vts
, confirmedProposals = cps
, appVersions = avs
, registeredSoftwareUpdateProposals = raus
} = st

rups = M.keysSet proposalRegistrationSlot

subEnv = Voting.Environment sn pps (Voting.RegistrationEnvironment rups dms)

subSt = Voting.State vts cps
@@ -5,14 +5,14 @@
-- This is an implementation of the rules defined in the Byron ledger
-- specification
module Cardano.Chain.Update.Validation.Registration
( RegistrationError
, RegistrationState(..)
( Error
, State(..)
, ProtocolUpdateProposals
, registerProposal
)
where

import Cardano.Prelude
import Cardano.Prelude hiding (State)

import qualified Data.ByteString as BS
import qualified Data.Map.Strict as M
@@ -28,20 +28,20 @@ import Cardano.Chain.Update.Vote
import Cardano.Crypto


-- | RegistrationState keeps track of registered protocol and software update
-- | State keeps track of registered protocol and software update
-- proposals
data RegistrationState = RegistrationState
data State = State
{ rsProtocolUpdateProposals :: !ProtocolUpdateProposals
, rsSoftwareUpdateProposals :: !SoftwareUpdateProposals
}

type ProtocolUpdateProposals = Map UpId (ProtocolVersion, ProtocolParameters)
type SoftwareUpdateProposals = Map UpId SoftwareVersion

type ApplicationVersions = Map ApplicationName (NumSoftwareVersion, SlotId)
type ApplicationVersions = Map ApplicationName (NumSoftwareVersion, FlatSlotId)

-- | RegistrationError captures the ways in which registration could fail
data RegistrationError
-- | Error captures the ways in which registration could fail
data Error
= RegistrationDuplicateProtocolVersion ProtocolVersion
| RegistrationDuplicateSoftwareVersion SoftwareVersion
| RegistrationInvalidProposer StakeholderId
@@ -62,17 +62,17 @@ data TooLarge n = TooLarge


-- | Register an update proposal after verifying its signature and validating
-- its contents. This corresponds to the `UPREG` rules in the spec.
-- its contents. This corresponds to the @UPREG@ rules in the spec.
registerProposal
:: MonadError RegistrationError m
:: MonadError Error m
=> ProtocolMagicId
-> ProtocolVersion
-> ProtocolParameters
-> ApplicationVersions
-> Map StakeholderId StakeholderId
-> RegistrationState
-> State
-> AProposal ByteString
-> m RegistrationState
-> m State
registerProposal pm adoptedPV adoptedPP appVersions delegation rs proposal = do

-- Check that the proposer is delegated to by a genesis key
@@ -95,13 +95,13 @@ registerProposal pm adoptedPV adoptedPP appVersions delegation rs proposal = do
-- The proposal may contain a protocol update, a software update, or both.
-- This corresponds to the `UPV` rules in the spec.
registerProposalComponents
:: MonadError RegistrationError m
:: MonadError Error m
=> ProtocolVersion
-> ProtocolParameters
-> ApplicationVersions
-> RegistrationState
-> State
-> AProposal ByteString
-> m RegistrationState
-> m State
registerProposalComponents adoptedPV adoptedPP appVersions rs proposal = do

(protocolVersionChanged || softwareVersionChanged)
@@ -117,7 +117,7 @@ registerProposalComponents adoptedPV adoptedPP appVersions rs proposal = do
then registerSoftwareUpdate appVersions registeredSUPs proposal
else pure registeredSUPs

pure $ RegistrationState registeredPUPs' registeredSUPs'
pure $ State registeredPUPs' registeredSUPs'
where
ProposalBody protocolVersion ppu softwareVersion _ _ =
proposalBody proposal
@@ -130,7 +130,7 @@ registerProposalComponents adoptedPV adoptedPP appVersions rs proposal = do
protocolVersionChanged =
not $ protocolVersion == adoptedPV && PPU.isEmpty ppu

RegistrationState registeredPUPs registeredSUPs = rs
State registeredPUPs registeredSUPs = rs


-- | Validate a protocol update
@@ -143,7 +143,7 @@ registerProposalComponents adoptedPV adoptedPP appVersions rs proposal = do
--
-- This corresponds to the `UPPVV` rule in the spec.
registerProtocolUpdate
:: MonadError RegistrationError m
:: MonadError Error m
=> ProtocolVersion
-> ProtocolParameters
-> ProtocolUpdateProposals
@@ -185,7 +185,7 @@ pvCanFollow newPV adoptedPV = adoptedPV < newPV && isNextVersion
--
-- This is where we enforce constraints on how the 'ProtocolParameters' change
canUpdate
:: MonadError RegistrationError m
:: MonadError Error m
=> ProtocolParameters
-> ProtocolParameters
-> AProposal ByteString
@@ -234,7 +234,7 @@ canUpdate adoptedPP newPP proposal = do
--
-- This corresponds to the `UPSVV` rule in the spec.
registerSoftwareUpdate
:: MonadError RegistrationError m
:: MonadError Error m
=> ApplicationVersions
-> SoftwareUpdateProposals
-> AProposal ByteString
Oops, something went wrong.

0 comments on commit ad4596f

Please sign in to comment.
You can’t perform that action at this time.