{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Shelley.Ledger.Inspect (
    ProtocolUpdate (..)
  , ShelleyLedgerUpdate (..)
  , UpdateProposal (..)
  , UpdateState (..)
  , protocolUpdates
  ) 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           GHC.Records

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           Cardano.Ledger.BaseTypes (strictMaybeToMaybe)
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Shelley.API as SL

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 instance Eq (Core.PParamsDelta era) => Eq (ProtocolUpdate era)
deriving instance Show (Core.PParamsDelta era) => Show (ProtocolUpdate era)

-- | Update proposal
--
-- As in Byron, a proposal is a partial map from parameters to their values.
data UpdateProposal era = UpdateProposal {
      -- | The protocol parameters changed by this update proposal
      --
      -- An update is /identified/ by how it updates the protocol parameters.
      UpdateProposal era -> PParamsDelta era
proposalParams  :: Core.PParamsDelta era

      -- | New version (if changed by this proposal)
      --
      -- The protocol version itself is also considered to be just another
      -- parameter, and parameters can change /without/ changing the protocol
      -- version, although a convention /could/ be established that the protocol
      -- version must change if any of the parameters do; but the specification
      -- itself does not mandate this.
      --
      -- We record the version separately for the convenience of the HFC.
    , UpdateProposal era -> Maybe ProtVer
proposalVersion :: Maybe SL.ProtVer

      -- | The 'EpochNo' the proposal becomes active in, if it is adopted
    , UpdateProposal era -> EpochNo
proposalEpoch   :: EpochNo
    }

deriving instance Eq (Core.PParamsDelta era) => Eq (UpdateProposal era)
deriving instance Show (Core.PParamsDelta era) => Show (UpdateProposal era)

-- | Proposal state
--
-- The update mechanism in Shelley is simpler than it is in Byron. There is no
-- distinction between votes and proposals: to \"vote\" for a proposal one
-- merely submits the exact same proposal. There is also no separate
-- endorsement step. The procedure is as follows:
--
-- 1. During each epoch, a genesis key can submit (via its delegates) zero,
--    one, or many proposals; each submission overrides the previous one.
-- 2. \"Voting\" (submitting of proposals) ends @2 * stabilityWindow@ slots
--    (i.e. @6k/f@) before the end of the epoch. In other words, proposals
--    for the upcoming epoch must be submitted within the first @4k/f@ slots
--    of this one.
-- 3. At the end of an epoch, if the majority of nodes (as determined by the
--    @Quorum@ specification constant, which must be greater than half the
--    nodes) have most recently submitted the same exact proposal, then it is
--    adopted.
-- 4. The next epoch is always started with a clean slate, proposals from the
--    previous epoch that didn't make it are discarded (except for "future
--    proposals" that are explicitly marked for future epochs).
data UpdateState c = UpdateState {
      -- | The genesis delegates that voted for this proposal
      UpdateState c -> [KeyHash 'Genesis c]
proposalVotes         :: [SL.KeyHash 'SL.Genesis c]

      -- | Has this proposal reached sufficient votes to be adopted?
    , 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 proto. ShelleyBasedEra era
    => SL.ShelleyGenesis era
    -> LedgerState (ShelleyBlock proto era)
    -> [ProtocolUpdate era]
protocolUpdates :: ShelleyGenesis era
-> LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era]
protocolUpdates ShelleyGenesis era
genesis LedgerState (ShelleyBlock proto era)
st = [
      ProtocolUpdate :: forall era.
UpdateProposal era
-> UpdateState (EraCrypto era) -> ProtocolUpdate era
ProtocolUpdate {
          protocolUpdateProposal :: UpdateProposal era
protocolUpdateProposal = UpdateProposal :: forall era.
PParamsDelta era -> Maybe ProtVer -> EpochNo -> UpdateProposal era
UpdateProposal {
              proposalParams :: PParamsDelta era
proposalParams  = PParamsDelta 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
$
                                  PParamsDelta era -> StrictMaybe ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" PParamsDelta 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
            }
        }
    | (PParamsDelta era
proposal, [KeyHash 'Genesis (EraCrypto era)]
votes) <- [(PParamsDelta era, [KeyHash 'Genesis (EraCrypto era)])]
proposalsInv
    ]
  where
    proposalsInv :: [(Core.PParamsDelta era, [SL.KeyHash 'SL.Genesis (EraCrypto era)])]
    proposalsInv :: [(PParamsDelta era, [KeyHash 'Genesis (EraCrypto era)])]
proposalsInv =
          ((PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
 -> (PParamsDelta era, KeyHash 'Genesis (EraCrypto era)))
-> [(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsDelta era, [KeyHash 'Genesis (EraCrypto era)])]
forall a b c. Eq b => (a -> (b, c)) -> [a] -> [(b, [c])]
groupSplit (PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
-> (PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
forall a. a -> a
id
        ([(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
 -> [(PParamsDelta era, [KeyHash 'Genesis (EraCrypto era)])])
-> ([(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
    -> [(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))])
-> [(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsDelta era, [KeyHash 'Genesis (EraCrypto era)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
 -> (PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
 -> Ordering)
-> [(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
 -> PParamsDelta era)
-> (PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
-> (PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
-> PParamsDelta era
forall a b. (a, b) -> a
fst)
        ([(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
 -> [(PParamsDelta era, [KeyHash 'Genesis (EraCrypto era)])])
-> [(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
-> [(PParamsDelta era, [KeyHash 'Genesis (EraCrypto era)])]
forall a b. (a -> b) -> a -> b
$ ((KeyHash 'Genesis (EraCrypto era), PParamsDelta era)
 -> (PParamsDelta era, KeyHash 'Genesis (EraCrypto era)))
-> [(KeyHash 'Genesis (EraCrypto era), PParamsDelta era)]
-> [(PParamsDelta era, KeyHash 'Genesis (EraCrypto era))]
forall a b. (a -> b) -> [a] -> [b]
map (KeyHash 'Genesis (EraCrypto era), PParamsDelta era)
-> (PParamsDelta era, KeyHash 'Genesis (EraCrypto era))
forall a b. (a, b) -> (b, a)
swap (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsDelta era)
-> [(KeyHash 'Genesis (EraCrypto era), PParamsDelta era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (KeyHash 'Genesis (EraCrypto era)) (PParamsDelta era)
proposals)

    -- Updated proposed within the proposal window
    proposals :: Map (SL.KeyHash 'SL.Genesis (EraCrypto era)) (Core.PParamsDelta era)
    SL.ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsDelta era)
proposals =
          PPUPState era -> ProposedPPUpdates era
forall era. PPUPState era -> ProposedPPUpdates era
SL.proposals
        (PPUPState era -> ProposedPPUpdates era)
-> (LedgerState (ShelleyBlock proto era) -> PPUPState era)
-> LedgerState (ShelleyBlock proto era)
-> ProposedPPUpdates era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxOState era -> PPUPState era
forall era. UTxOState era -> State (EraRule "PPUP" era)
SL._ppups
        (UTxOState era -> PPUPState era)
-> (LedgerState (ShelleyBlock proto era) -> UTxOState era)
-> LedgerState (ShelleyBlock proto era)
-> PPUPState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
SL.lsUTxOState
        (LedgerState era -> UTxOState era)
-> (LedgerState (ShelleyBlock proto era) -> LedgerState era)
-> LedgerState (ShelleyBlock proto 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 proto era) -> EpochState era)
-> LedgerState (ShelleyBlock proto 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 proto era) -> NewEpochState era)
-> LedgerState (ShelleyBlock proto era)
-> EpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState
        (LedgerState (ShelleyBlock proto era) -> ProposedPPUpdates era)
-> LedgerState (ShelleyBlock proto era) -> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$ LedgerState (ShelleyBlock proto era)
st

    -- A proposal is accepted if the number of votes is equal to or greater
    -- than the quorum. The quorum itself must be strictly greater than half
    -- the number of genesis keys, but we do not rely on that property here.
    quorum :: Word64
    quorum :: Word64
quorum = ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgUpdateQuorum ShelleyGenesis era
genesis

    -- The proposals in 'SL.proposals' are for the upcoming epoch
    -- (we ignore 'futureProposals')
    currentEpoch :: EpochNo
    currentEpoch :: EpochNo
currentEpoch = NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
SL.nesEL (NewEpochState era -> EpochNo)
-> (LedgerState (ShelleyBlock proto era) -> NewEpochState era)
-> LedgerState (ShelleyBlock proto era)
-> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState (LedgerState (ShelleyBlock proto era) -> EpochNo)
-> LedgerState (ShelleyBlock proto era) -> EpochNo
forall a b. (a -> b) -> a -> b
$ LedgerState (ShelleyBlock proto era)
st

{-------------------------------------------------------------------------------
  Inspection
-------------------------------------------------------------------------------}

data ShelleyLedgerUpdate era =
    ShelleyUpdatedProtocolUpdates [ProtocolUpdate era]

deriving instance Eq (Core.PParamsDelta era) => Eq (ShelleyLedgerUpdate era)
deriving instance Show (Core.PParamsDelta era) => Show (ShelleyLedgerUpdate era)

instance Show (Core.PParamsDelta era) => Condense (ShelleyLedgerUpdate era) where
  condense :: ShelleyLedgerUpdate era -> String
condense = ShelleyLedgerUpdate era -> String
forall a. Show a => a -> String
show

instance ShelleyBasedEra era => InspectLedger (ShelleyBlock proto era) where
  type LedgerWarning (ShelleyBlock proto era) = Void
  type LedgerUpdate  (ShelleyBlock proto era) = ShelleyLedgerUpdate era

  inspectLedger :: TopLevelConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era)
-> [LedgerEvent (ShelleyBlock proto era)]
inspectLedger TopLevelConfig (ShelleyBlock proto era)
tlc LedgerState (ShelleyBlock proto era)
before LedgerState (ShelleyBlock proto 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 proto era)
-> [LedgerEvent (ShelleyBlock proto era)]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (ShelleyBlock proto era)
 -> [LedgerEvent (ShelleyBlock proto era)])
-> LedgerEvent (ShelleyBlock proto era)
-> [LedgerEvent (ShelleyBlock proto era)]
forall a b. (a -> b) -> a -> b
$ LedgerUpdate (ShelleyBlock proto era)
-> LedgerEvent (ShelleyBlock proto era)
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate (LedgerUpdate (ShelleyBlock proto era)
 -> LedgerEvent (ShelleyBlock proto era))
-> LedgerUpdate (ShelleyBlock proto era)
-> LedgerEvent (ShelleyBlock proto 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 proto era)
-> LedgerConfig (ShelleyBlock proto era)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (ShelleyBlock proto era)
tlc)

      updatesBefore, updatesAfter :: [ProtocolUpdate era]
      updatesBefore :: [ProtocolUpdate era]
updatesBefore = ShelleyGenesis era
-> LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era]
forall era proto.
ShelleyBasedEra era =>
ShelleyGenesis era
-> LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era]
protocolUpdates ShelleyGenesis era
genesis LedgerState (ShelleyBlock proto era)
before
      updatesAfter :: [ProtocolUpdate era]
updatesAfter  = ShelleyGenesis era
-> LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era]
forall era proto.
ShelleyBasedEra era =>
ShelleyGenesis era
-> LedgerState (ShelleyBlock proto era) -> [ProtocolUpdate era]
protocolUpdates ShelleyGenesis era
genesis LedgerState (ShelleyBlock proto era)
after