{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Shelley.Ledger.Inspect (
ProtocolUpdate(..)
, UpdateProposal(..)
, UpdateState(..)
, protocolUpdates
, ShelleyLedgerUpdate (..)
) where
import Control.Monad
import Data.List (sortBy)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Ord (comparing)
import Data.Tuple (swap)
import Data.Void
import Data.Word (Word64)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Inspect
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.Condense
import qualified Shelley.Spec.Ledger.API as SL
import Shelley.Spec.Ledger.BaseTypes (strictMaybeToMaybe)
import qualified Shelley.Spec.Ledger.PParams as SL (PParamsUpdate)
import Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Ledger
data ProtocolUpdate era = ProtocolUpdate {
ProtocolUpdate era -> UpdateProposal era
protocolUpdateProposal :: UpdateProposal era
, ProtocolUpdate era -> UpdateState (EraCrypto era)
protocolUpdateState :: UpdateState (EraCrypto era)
}
deriving (Int -> ProtocolUpdate era -> ShowS
[ProtocolUpdate era] -> ShowS
ProtocolUpdate era -> String
(Int -> ProtocolUpdate era -> ShowS)
-> (ProtocolUpdate era -> String)
-> ([ProtocolUpdate era] -> ShowS)
-> Show (ProtocolUpdate era)
forall era. Int -> ProtocolUpdate era -> ShowS
forall era. [ProtocolUpdate era] -> ShowS
forall era. ProtocolUpdate era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProtocolUpdate era] -> ShowS
$cshowList :: forall era. [ProtocolUpdate era] -> ShowS
show :: ProtocolUpdate era -> String
$cshow :: forall era. ProtocolUpdate era -> String
showsPrec :: Int -> ProtocolUpdate era -> ShowS
$cshowsPrec :: forall era. Int -> ProtocolUpdate era -> ShowS
Show, ProtocolUpdate era -> ProtocolUpdate era -> Bool
(ProtocolUpdate era -> ProtocolUpdate era -> Bool)
-> (ProtocolUpdate era -> ProtocolUpdate era -> Bool)
-> Eq (ProtocolUpdate era)
forall era. ProtocolUpdate era -> ProtocolUpdate era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProtocolUpdate era -> ProtocolUpdate era -> Bool
$c/= :: forall era. ProtocolUpdate era -> ProtocolUpdate era -> Bool
== :: ProtocolUpdate era -> ProtocolUpdate era -> Bool
$c== :: forall era. ProtocolUpdate era -> ProtocolUpdate era -> Bool
Eq)
data UpdateProposal era = UpdateProposal {
UpdateProposal era -> PParamsUpdate era
proposalParams :: SL.PParamsUpdate era
, UpdateProposal era -> Maybe ProtVer
proposalVersion :: Maybe SL.ProtVer
, UpdateProposal era -> EpochNo
proposalEpoch :: EpochNo
}
deriving (Int -> UpdateProposal era -> ShowS
[UpdateProposal era] -> ShowS
UpdateProposal era -> String
(Int -> UpdateProposal era -> ShowS)
-> (UpdateProposal era -> String)
-> ([UpdateProposal era] -> ShowS)
-> Show (UpdateProposal era)
forall era. Int -> UpdateProposal era -> ShowS
forall era. [UpdateProposal era] -> ShowS
forall era. UpdateProposal era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UpdateProposal era] -> ShowS
$cshowList :: forall era. [UpdateProposal era] -> ShowS
show :: UpdateProposal era -> String
$cshow :: forall era. UpdateProposal era -> String
showsPrec :: Int -> UpdateProposal era -> ShowS
$cshowsPrec :: forall era. Int -> UpdateProposal era -> ShowS
Show, UpdateProposal era -> UpdateProposal era -> Bool
(UpdateProposal era -> UpdateProposal era -> Bool)
-> (UpdateProposal era -> UpdateProposal era -> Bool)
-> Eq (UpdateProposal era)
forall era. UpdateProposal era -> UpdateProposal era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UpdateProposal era -> UpdateProposal era -> Bool
$c/= :: forall era. UpdateProposal era -> UpdateProposal era -> Bool
== :: UpdateProposal era -> UpdateProposal era -> Bool
$c== :: forall era. UpdateProposal era -> UpdateProposal era -> Bool
Eq)
data UpdateState c = UpdateState {
UpdateState c -> [KeyHash 'Genesis c]
proposalVotes :: [SL.KeyHash 'SL.Genesis c]
, UpdateState c -> Bool
proposalReachedQuorum :: Bool
}
deriving (Int -> UpdateState c -> ShowS
[UpdateState c] -> ShowS
UpdateState c -> String
(Int -> UpdateState c -> ShowS)
-> (UpdateState c -> String)
-> ([UpdateState c] -> ShowS)
-> Show (UpdateState c)
forall c. Int -> UpdateState c -> ShowS
forall c. [UpdateState c] -> ShowS
forall c. UpdateState c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UpdateState c] -> ShowS
$cshowList :: forall c. [UpdateState c] -> ShowS
show :: UpdateState c -> String
$cshow :: forall c. UpdateState c -> String
showsPrec :: Int -> UpdateState c -> ShowS
$cshowsPrec :: forall c. Int -> UpdateState c -> ShowS
Show, UpdateState c -> UpdateState c -> Bool
(UpdateState c -> UpdateState c -> Bool)
-> (UpdateState c -> UpdateState c -> Bool) -> Eq (UpdateState c)
forall c. UpdateState c -> UpdateState c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UpdateState c -> UpdateState c -> Bool
$c/= :: forall c. UpdateState c -> UpdateState c -> Bool
== :: UpdateState c -> UpdateState c -> Bool
$c== :: forall c. UpdateState c -> UpdateState c -> Bool
Eq)
protocolUpdates ::
forall era.
SL.ShelleyGenesis era
-> LedgerState (ShelleyBlock era)
-> [ProtocolUpdate era]
protocolUpdates :: ShelleyGenesis era
-> LedgerState (ShelleyBlock era) -> [ProtocolUpdate era]
protocolUpdates ShelleyGenesis era
genesis LedgerState (ShelleyBlock era)
st = [
ProtocolUpdate :: forall era.
UpdateProposal era
-> UpdateState (EraCrypto era) -> ProtocolUpdate era
ProtocolUpdate {
protocolUpdateProposal :: UpdateProposal era
protocolUpdateProposal = UpdateProposal :: forall era.
PParamsUpdate era -> Maybe ProtVer -> EpochNo -> UpdateProposal era
UpdateProposal {
proposalParams :: PParamsUpdate era
proposalParams = PParamsUpdate era
proposal
, proposalEpoch :: EpochNo
proposalEpoch = EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
currentEpoch
, proposalVersion :: Maybe ProtVer
proposalVersion = StrictMaybe ProtVer -> Maybe ProtVer
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (StrictMaybe ProtVer -> Maybe ProtVer)
-> StrictMaybe ProtVer -> Maybe ProtVer
forall a b. (a -> b) -> a -> b
$
PParamsUpdate era -> HKD StrictMaybe ProtVer
forall (f :: * -> *) era. PParams' f era -> HKD f ProtVer
SL._protocolVersion PParamsUpdate era
proposal
}
, protocolUpdateState :: UpdateState (EraCrypto era)
protocolUpdateState = UpdateState :: forall c. [KeyHash 'Genesis c] -> Bool -> UpdateState c
UpdateState {
proposalVotes :: [KeyHash 'Genesis (EraCrypto era)]
proposalVotes = [KeyHash 'Genesis (EraCrypto era)]
votes
, proposalReachedQuorum :: Bool
proposalReachedQuorum = [KeyHash 'Genesis (EraCrypto era)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [KeyHash 'Genesis (EraCrypto era)]
votes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
quorum
}
}
| (PParamsUpdate era
proposal, [KeyHash 'Genesis (EraCrypto era)]
votes) <- [(PParamsUpdate era, [KeyHash 'Genesis (EraCrypto era)])]
proposalsInv
]
where
proposalsInv :: [(SL.PParamsUpdate era, [SL.KeyHash 'SL.Genesis (EraCrypto era)])]
proposalsInv :: [(PParamsUpdate era, [KeyHash 'Genesis (EraCrypto era)])]
proposalsInv =
((PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era)))
-> [(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsUpdate era, [KeyHash 'Genesis (EraCrypto era)])]
forall a b c. Eq b => (a -> (b, c)) -> [a] -> [(b, [c])]
groupSplit (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
forall a. a -> a
id
([(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsUpdate era, [KeyHash 'Genesis (EraCrypto era)])])
-> ([(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))])
-> [(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsUpdate era, [KeyHash 'Genesis (EraCrypto era)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> Ordering)
-> [(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> PParamsUpdate era)
-> (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
-> PParamsUpdate era
forall a b. (a, b) -> a
fst)
([(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsUpdate era, [KeyHash 'Genesis (EraCrypto era)])])
-> [(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsUpdate era, [KeyHash 'Genesis (EraCrypto era)])]
forall a b. (a -> b) -> a -> b
$ ((KeyHash 'Genesis (EraCrypto era), PParamsUpdate era)
-> (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era)))
-> [(KeyHash 'Genesis (EraCrypto era), PParamsUpdate era)]
-> [(PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))]
forall a b. (a -> b) -> [a] -> [b]
map (KeyHash 'Genesis (EraCrypto era), PParamsUpdate era)
-> (PParamsUpdate era, KeyHash 'Genesis (EraCrypto era))
forall a b. (a, b) -> (b, a)
swap (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> [(KeyHash 'Genesis (EraCrypto era), PParamsUpdate era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
proposals)
proposals :: Map (SL.KeyHash 'SL.Genesis (EraCrypto era)) (SL.PParamsUpdate era)
SL.ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
proposals =
PPUPState era -> ProposedPPUpdates era
forall era. PPUPState era -> ProposedPPUpdates era
SL.proposals
(PPUPState era -> ProposedPPUpdates era)
-> (LedgerState (ShelleyBlock era) -> PPUPState era)
-> LedgerState (ShelleyBlock era)
-> ProposedPPUpdates era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxOState era -> PPUPState era
forall era. UTxOState era -> PPUPState era
SL._ppups
(UTxOState era -> PPUPState era)
-> (LedgerState (ShelleyBlock era) -> UTxOState era)
-> LedgerState (ShelleyBlock era)
-> PPUPState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
SL._utxoState
(LedgerState era -> UTxOState era)
-> (LedgerState (ShelleyBlock era) -> LedgerState era)
-> LedgerState (ShelleyBlock era)
-> UTxOState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
SL.esLState
(EpochState era -> LedgerState era)
-> (LedgerState (ShelleyBlock era) -> EpochState era)
-> LedgerState (ShelleyBlock era)
-> LedgerState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
SL.nesEs
(NewEpochState era -> EpochState era)
-> (LedgerState (ShelleyBlock era) -> NewEpochState era)
-> LedgerState (ShelleyBlock era)
-> EpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock era) -> NewEpochState era
forall era. LedgerState (ShelleyBlock era) -> NewEpochState era
shelleyLedgerState
(LedgerState (ShelleyBlock era) -> ProposedPPUpdates era)
-> LedgerState (ShelleyBlock era) -> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$ LedgerState (ShelleyBlock era)
st
quorum :: Word64
quorum :: Word64
quorum = ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgUpdateQuorum ShelleyGenesis era
genesis
currentEpoch :: EpochNo
currentEpoch :: EpochNo
currentEpoch = NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
SL.nesEL (NewEpochState era -> EpochNo)
-> (LedgerState (ShelleyBlock era) -> NewEpochState era)
-> LedgerState (ShelleyBlock era)
-> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock era) -> NewEpochState era
forall era. LedgerState (ShelleyBlock era) -> NewEpochState era
shelleyLedgerState (LedgerState (ShelleyBlock era) -> EpochNo)
-> LedgerState (ShelleyBlock era) -> EpochNo
forall a b. (a -> b) -> a -> b
$ LedgerState (ShelleyBlock era)
st
data ShelleyLedgerUpdate era =
ShelleyUpdatedProtocolUpdates [ProtocolUpdate era]
deriving (Int -> ShelleyLedgerUpdate era -> ShowS
[ShelleyLedgerUpdate era] -> ShowS
ShelleyLedgerUpdate era -> String
(Int -> ShelleyLedgerUpdate era -> ShowS)
-> (ShelleyLedgerUpdate era -> String)
-> ([ShelleyLedgerUpdate era] -> ShowS)
-> Show (ShelleyLedgerUpdate era)
forall era. Int -> ShelleyLedgerUpdate era -> ShowS
forall era. [ShelleyLedgerUpdate era] -> ShowS
forall era. ShelleyLedgerUpdate era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyLedgerUpdate era] -> ShowS
$cshowList :: forall era. [ShelleyLedgerUpdate era] -> ShowS
show :: ShelleyLedgerUpdate era -> String
$cshow :: forall era. ShelleyLedgerUpdate era -> String
showsPrec :: Int -> ShelleyLedgerUpdate era -> ShowS
$cshowsPrec :: forall era. Int -> ShelleyLedgerUpdate era -> ShowS
Show, ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool
(ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool)
-> (ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool)
-> Eq (ShelleyLedgerUpdate era)
forall era.
ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool
$c/= :: forall era.
ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool
== :: ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool
$c== :: forall era.
ShelleyLedgerUpdate era -> ShelleyLedgerUpdate era -> Bool
Eq)
instance Condense (ShelleyLedgerUpdate era) where
condense :: ShelleyLedgerUpdate era -> String
condense = ShelleyLedgerUpdate era -> String
forall a. Show a => a -> String
show
instance InspectLedger (ShelleyBlock era) where
type LedgerWarning (ShelleyBlock era) = Void
type LedgerUpdate (ShelleyBlock era) = ShelleyLedgerUpdate era
inspectLedger :: TopLevelConfig (ShelleyBlock era)
-> LedgerState (ShelleyBlock era)
-> LedgerState (ShelleyBlock era)
-> [LedgerEvent (ShelleyBlock era)]
inspectLedger TopLevelConfig (ShelleyBlock era)
tlc LedgerState (ShelleyBlock era)
before LedgerState (ShelleyBlock era)
after = do
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ [ProtocolUpdate era]
updatesBefore [ProtocolUpdate era] -> [ProtocolUpdate era] -> Bool
forall a. Eq a => a -> a -> Bool
/= [ProtocolUpdate era]
updatesAfter
LedgerEvent (ShelleyBlock era) -> [LedgerEvent (ShelleyBlock era)]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (ShelleyBlock era)
-> [LedgerEvent (ShelleyBlock era)])
-> LedgerEvent (ShelleyBlock era)
-> [LedgerEvent (ShelleyBlock era)]
forall a b. (a -> b) -> a -> b
$ LedgerUpdate (ShelleyBlock era) -> LedgerEvent (ShelleyBlock era)
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate (LedgerUpdate (ShelleyBlock era) -> LedgerEvent (ShelleyBlock era))
-> LedgerUpdate (ShelleyBlock era)
-> LedgerEvent (ShelleyBlock era)
forall a b. (a -> b) -> a -> b
$ [ProtocolUpdate era] -> ShelleyLedgerUpdate era
forall era. [ProtocolUpdate era] -> ShelleyLedgerUpdate era
ShelleyUpdatedProtocolUpdates [ProtocolUpdate era]
updatesAfter
where
genesis :: SL.ShelleyGenesis era
genesis :: ShelleyGenesis era
genesis = ShelleyLedgerConfig era -> ShelleyGenesis era
forall era. ShelleyLedgerConfig era -> ShelleyGenesis era
shelleyLedgerGenesis (TopLevelConfig (ShelleyBlock era)
-> LedgerConfig (ShelleyBlock era)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (ShelleyBlock era)
tlc)
updatesBefore, updatesAfter :: [ProtocolUpdate era]
updatesBefore :: [ProtocolUpdate era]
updatesBefore = ShelleyGenesis era
-> LedgerState (ShelleyBlock era) -> [ProtocolUpdate era]
forall era.
ShelleyGenesis era
-> LedgerState (ShelleyBlock era) -> [ProtocolUpdate era]
protocolUpdates ShelleyGenesis era
genesis LedgerState (ShelleyBlock era)
before
updatesAfter :: [ProtocolUpdate era]
updatesAfter = ShelleyGenesis era
-> LedgerState (ShelleyBlock era) -> [ProtocolUpdate era]
forall era.
ShelleyGenesis era
-> LedgerState (ShelleyBlock era) -> [ProtocolUpdate era]
protocolUpdates ShelleyGenesis era
genesis LedgerState (ShelleyBlock era)
after