Skip to content
Permalink
Browse files

Remove the use of lens from `Cardano.Chain.Update.Validation.Interface`

  • Loading branch information...
dnadales committed Mar 14, 2019
1 parent f05b25e commit ef18c60f7bdac50f26d50de09b808bb7f4f8739b
Showing with 65 additions and 66 deletions.
  1. +65 −66 src/Cardano/Chain/Update/Validation/Interface.hs
@@ -1,31 +1,14 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | Blockchain interface validation rules.
--
module Cardano.Chain.Update.Validation.Interface
( -- * Environment
Environment (..)
-- ** Lenses
, protocolMagic
, currentEpoch
, currentSlot
, delegationMap
-- * State
, State (..)
-- * Lenses
, prevEpoch
, adoptedProtocolVersion
, adoptedProtocolParams
, futureAdopts
, appVersions
, registeredProtocolUpdateProposals
, registeredSoftwareUpdateProposals
, confirmedProposals
, proposalVotes
, proposalsEndorsements
, proposalRegistrationSlot
-- *Error
, Error (..)
-- * Interface functions
@@ -40,13 +23,11 @@ import Cardano.Prelude
, MonadError
, Set
, ($!)
, (&)
, pure
, wrapError
, elem
)

import Control.Lens ((.~), makeLenses, (^.), (%~))
import qualified Data.Map.Strict as M

import Cardano.Chain.Slotting (EpochIndex, FlatSlotId)
@@ -70,43 +51,39 @@ data TODO

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

makeLenses ''Environment

-- | Update interface state.
data State
= State
{ _prevEpoch :: !EpochIndex
{ prevEpoch :: !EpochIndex
-- ^ Previously seen epoch
, _adoptedProtocolVersion :: !ProtocolVersion
, _adoptedProtocolParams :: !ProtocolParameters
, adoptedProtocolVersion :: !ProtocolVersion
, adoptedProtocolParams :: !ProtocolParameters
-- ^ Adopted protocol parameters
, _futureAdopts :: !TODO -- We should take this from Cardano.Chain.Update.Validation.Endorsement
, futureAdopts :: !TODO -- We should take this from Cardano.Chain.Update.Validation.Endorsement
-- ^ Future protocol version adoptions
, _appVersions :: !(Map ApplicationName (NumSoftwareVersion, FlatSlotId))
, appVersions :: !(Map ApplicationName (NumSoftwareVersion, FlatSlotId))
-- ^ Current application versions (by application name)
, _registeredProtocolUpdateProposals :: !(Map UpId (ProtocolVersion, ProtocolParameters))
, registeredProtocolUpdateProposals :: !(Map UpId (ProtocolVersion, ProtocolParameters))
-- ^ Registered protocol update proposals
, _registeredSoftwareUpdateProposals :: !(Map UpId SoftwareVersion)
, registeredSoftwareUpdateProposals :: !(Map UpId SoftwareVersion)
-- ^ Registered software update proposals
, _confirmedProposals :: !(Map UpId FlatSlotId)
, confirmedProposals :: !(Map UpId FlatSlotId)
-- ^ Confirmed update proposals
, _proposalVotes :: !(Map UpId (Set StakeholderId))
, proposalVotes :: !(Map UpId (Set StakeholderId))
-- ^ Update proposals votes
, _proposalsEndorsements :: TODO -- We should take this from Cardano.Chain.Update.Validation.Endorsement
, 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
, proposalRegistrationSlot :: Map UpId FlatSlotId
-- ^ Slot at which an update proposal was registered
}

makeLenses ''State

data Error
= Registration Registration.Error
| Voting Voting.Error
@@ -122,21 +99,32 @@ registerProposal
-> m State
registerProposal env st proposal = do
let
pm = env ^. protocolMagic
pv = st ^. adoptedProtocolVersion
pps = st ^. adoptedProtocolParams
avs = st ^. appVersions
dms = env ^. delegationMap
rpus = st ^. registeredProtocolUpdateProposals
raus = st ^. registeredSoftwareUpdateProposals
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)
Registration.registerProposal pm pv pps avs dms regSubSt proposal
`wrapError` Registration
pure $! st
& registeredProtocolUpdateProposals .~ rpus'
& registeredSoftwareUpdateProposals .~ raus'
& proposalRegistrationSlot %~ M.insert (recoverUpId proposal) (env ^. currentSlot)
pure $!
st { registeredProtocolUpdateProposals = rpus'
, registeredSoftwareUpdateProposals = raus'
, proposalRegistrationSlot = M.insert (recoverUpId proposal) currentSlot pws
}

-- | Register a vote for the given proposal.
--
@@ -151,15 +139,25 @@ registerVote
-> AVote ByteString
-> m State
registerVote env st vote = do
let pm = env ^. protocolMagic
subEnv = Voting.Environment sn pps (Voting.RegistrationEnvironment rups dms)
sn = env ^. currentSlot
pps = st ^. adoptedProtocolParams
rups = M.keysSet (st ^. proposalRegistrationSlot)
dms = env ^. delegationMap
subSt = Voting.State vts cps
vts = st ^. proposalVotes
cps = st ^. confirmedProposals
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
@@ -168,10 +166,11 @@ registerVote env st vote = do
| (pid, sv) <- M.toList raus
, pid `elem` M.keys cps'
]
raus = st ^. registeredSoftwareUpdateProposals
pure $! st
& confirmedProposals .~ cps'
& proposalVotes .~ vts'
& appVersions %~ M.union avsNew
& registeredSoftwareUpdateProposals %~ (`M.withoutKeys` M.keysSet cps)
raus = registeredSoftwareUpdateProposals
pure $!
st { confirmedProposals = cps'
, proposalVotes = vts'
, appVersions = M.union avsNew appVersions
, registeredSoftwareUpdateProposals = M.withoutKeys raus (M.keysSet cps)
}
-- TODO: consider using the `Relation` instances from `fm-ledger-rules` (see `Ledger.Core`)

0 comments on commit ef18c60

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