Skip to content
Permalink
Browse files

Address Ru' second batch of remarks.

  • Loading branch information...
dnadales committed Mar 15, 2019
1 parent 2d4bf76 commit 3349c369d2135147ff06cf800af38ffd097fa7db
Showing with 75 additions and 84 deletions.
  1. +75 −84 src/Cardano/Chain/Update/Validation/Interface.hs
@@ -17,16 +17,7 @@ module Cardano.Chain.Update.Validation.Interface
)
where

import Cardano.Prelude
( ByteString
, Map
, MonadError
, Set
, ($!)
, pure
, wrapError
, elem
)
import Cardano.Prelude hiding (State)

import qualified Data.Map.Strict as M

@@ -49,40 +40,38 @@ import Cardano.Crypto (ProtocolMagicId)

data TODO

data Environment
= Environment
data Environment = Environment
{ protocolMagic :: ProtocolMagicId
, currentEpoch :: !EpochIndex
, currentSlot :: !FlatSlotId
, 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 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
@@ -98,25 +87,6 @@ registerProposal
-> AProposal ByteString
-> m State
registerProposal env st proposal = do
let
Environment { protocolMagic, currentSlot, delegationMap } = env
State
{ adoptedProtocolVersion
, adoptedProtocolParams
, appVersions
, registeredProtocolUpdateProposals
, registeredSoftwareUpdateProposals
, proposalRegistrationSlot
} = st
pm = protocolMagic
pv = adoptedProtocolVersion
pps = adoptedProtocolParams
avs = appVersions
dms = delegationMap
rpus = registeredProtocolUpdateProposals
raus = registeredSoftwareUpdateProposals
pws = proposalRegistrationSlot
regSubSt = Registration.State rpus raus
Registration.State rpus' raus' <-
Registration.registerProposal pm pv pps avs dms regSubSt proposal
`wrapError` Registration
@@ -125,6 +95,23 @@ registerProposal env st proposal = do
, 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.
--
@@ -139,38 +126,42 @@ registerVote
-> AVote ByteString
-> m State
registerVote env st vote = do
let
Environment { protocolMagic, currentSlot, delegationMap } = env
State
{ adoptedProtocolParams
, proposalRegistrationSlot
, proposalVotes
, confirmedProposals
, appVersions
, registeredSoftwareUpdateProposals
} = st
pm = protocolMagic
subEnv = Voting.Environment sn pps (Voting.RegistrationEnvironment rups dms)
sn = currentSlot
pps = adoptedProtocolParams
rups = M.keysSet proposalRegistrationSlot
dms = delegationMap
subSt = Voting.State vts cps
vts = proposalVotes
cps = confirmedProposals
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'
]
raus = registeredSoftwareUpdateProposals
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 appVersions
, 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

0 comments on commit 3349c36

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