{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeFamilies      #-}

module Ouroboros.Consensus.Mock.Protocol.LeaderSchedule (
    ConsensusConfig (..)
  , LeaderSchedule (..)
  , WithLeaderSchedule
  , leaderScheduleFor
  ) where

import qualified Data.Map.Strict as Map
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Ouroboros.Consensus.NodeId (CoreNodeId (..))
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Protocol.LeaderSchedule
import           Ouroboros.Consensus.Ticked

{-------------------------------------------------------------------------------
  ConsensusProtocol instance that overrides leader selection

  Using a provided LeaderSchedule, this instance will override the computation
  for checking leadership and just take the leader from the provided schedule.
-------------------------------------------------------------------------------}

-- | Extension of protocol @p@ by a static leader schedule.
data WithLeaderSchedule p

data instance ConsensusConfig (WithLeaderSchedule p) = WLSConfig {
      ConsensusConfig (WithLeaderSchedule p) -> LeaderSchedule
wlsConfigSchedule :: !LeaderSchedule
    , ConsensusConfig (WithLeaderSchedule p) -> ConsensusConfig p
wlsConfigP        :: !(ConsensusConfig p)
    , ConsensusConfig (WithLeaderSchedule p) -> CoreNodeId
wlsConfigNodeId   :: !CoreNodeId
    }
  deriving ((forall x.
 ConsensusConfig (WithLeaderSchedule p)
 -> Rep (ConsensusConfig (WithLeaderSchedule p)) x)
-> (forall x.
    Rep (ConsensusConfig (WithLeaderSchedule p)) x
    -> ConsensusConfig (WithLeaderSchedule p))
-> Generic (ConsensusConfig (WithLeaderSchedule p))
forall x.
Rep (ConsensusConfig (WithLeaderSchedule p)) x
-> ConsensusConfig (WithLeaderSchedule p)
forall x.
ConsensusConfig (WithLeaderSchedule p)
-> Rep (ConsensusConfig (WithLeaderSchedule p)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p x.
Rep (ConsensusConfig (WithLeaderSchedule p)) x
-> ConsensusConfig (WithLeaderSchedule p)
forall p x.
ConsensusConfig (WithLeaderSchedule p)
-> Rep (ConsensusConfig (WithLeaderSchedule p)) x
$cto :: forall p x.
Rep (ConsensusConfig (WithLeaderSchedule p)) x
-> ConsensusConfig (WithLeaderSchedule p)
$cfrom :: forall p x.
ConsensusConfig (WithLeaderSchedule p)
-> Rep (ConsensusConfig (WithLeaderSchedule p)) x
Generic)

instance ConsensusProtocol p => ConsensusProtocol (WithLeaderSchedule p) where
  type SelectView    (WithLeaderSchedule p) = SelectView p

  type ChainDepState (WithLeaderSchedule p) = ()
  type LedgerView    (WithLeaderSchedule p) = ()
  type ValidationErr (WithLeaderSchedule p) = ()
  type IsLeader      (WithLeaderSchedule p) = ()
  type ValidateView  (WithLeaderSchedule p) = ()
  type CanBeLeader   (WithLeaderSchedule p) = ()

  protocolSecurityParam :: ConsensusConfig (WithLeaderSchedule p) -> SecurityParam
protocolSecurityParam = ConsensusConfig p -> SecurityParam
forall p. ConsensusProtocol p => ConsensusConfig p -> SecurityParam
protocolSecurityParam (ConsensusConfig p -> SecurityParam)
-> (ConsensusConfig (WithLeaderSchedule p) -> ConsensusConfig p)
-> ConsensusConfig (WithLeaderSchedule p)
-> SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (WithLeaderSchedule p) -> ConsensusConfig p
forall p.
ConsensusConfig (WithLeaderSchedule p) -> ConsensusConfig p
wlsConfigP

  checkIsLeader :: ConsensusConfig (WithLeaderSchedule p)
-> CanBeLeader (WithLeaderSchedule p)
-> SlotNo
-> Ticked (ChainDepState (WithLeaderSchedule p))
-> Maybe (IsLeader (WithLeaderSchedule p))
checkIsLeader WLSConfig{..} () SlotNo
slot Ticked (ChainDepState (WithLeaderSchedule p))
_ =
    case SlotNo -> Map SlotNo [CoreNodeId] -> Maybe [CoreNodeId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SlotNo
slot (Map SlotNo [CoreNodeId] -> Maybe [CoreNodeId])
-> Map SlotNo [CoreNodeId] -> Maybe [CoreNodeId]
forall a b. (a -> b) -> a -> b
$ LeaderSchedule -> Map SlotNo [CoreNodeId]
getLeaderSchedule LeaderSchedule
wlsConfigSchedule of
        Maybe [CoreNodeId]
Nothing -> [Char] -> Maybe ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe ()) -> [Char] -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Char]
"WithLeaderSchedule: missing slot " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SlotNo -> [Char]
forall a. Show a => a -> [Char]
show SlotNo
slot
        Just [CoreNodeId]
nids
            | CoreNodeId
wlsConfigNodeId CoreNodeId -> [CoreNodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CoreNodeId]
nids -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
            | Bool
otherwise                   -> Maybe (IsLeader (WithLeaderSchedule p))
forall a. Maybe a
Nothing

  tickChainDepState :: ConsensusConfig (WithLeaderSchedule p)
-> Ticked (LedgerView (WithLeaderSchedule p))
-> SlotNo
-> ChainDepState (WithLeaderSchedule p)
-> Ticked (ChainDepState (WithLeaderSchedule p))
tickChainDepState     ConsensusConfig (WithLeaderSchedule p)
_ Ticked (LedgerView (WithLeaderSchedule p))
_ SlotNo
_ ChainDepState (WithLeaderSchedule p)
_ = Ticked ()
Ticked (ChainDepState (WithLeaderSchedule p))
TickedTrivial
  updateChainDepState :: ConsensusConfig (WithLeaderSchedule p)
-> ValidateView (WithLeaderSchedule p)
-> SlotNo
-> Ticked (ChainDepState (WithLeaderSchedule p))
-> Except
     (ValidationErr (WithLeaderSchedule p))
     (ChainDepState (WithLeaderSchedule p))
updateChainDepState   ConsensusConfig (WithLeaderSchedule p)
_ ValidateView (WithLeaderSchedule p)
_ SlotNo
_ Ticked (ChainDepState (WithLeaderSchedule p))
_ = () -> ExceptT () Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  reupdateChainDepState :: ConsensusConfig (WithLeaderSchedule p)
-> ValidateView (WithLeaderSchedule p)
-> SlotNo
-> Ticked (ChainDepState (WithLeaderSchedule p))
-> ChainDepState (WithLeaderSchedule p)
reupdateChainDepState ConsensusConfig (WithLeaderSchedule p)
_ ValidateView (WithLeaderSchedule p)
_ SlotNo
_ Ticked (ChainDepState (WithLeaderSchedule p))
_ = ()

instance ConsensusProtocol p
      => NoThunks (ConsensusConfig (WithLeaderSchedule p))