{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}

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

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

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.NodeId (CoreNodeId (..), fromCoreNodeId)
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util.Condense (Condense (..))

{-------------------------------------------------------------------------------
  Leader schedule

  The leader schedule allows us to define, in tests, precisely when each node
  is meant to lead. Unlike in, say, Praos, where this is determined by a single
  random seed, this gives us the ability to construct test cases in an
  inspectable and shrinkable manner.
-------------------------------------------------------------------------------}

newtype LeaderSchedule = LeaderSchedule {
        LeaderSchedule -> Map SlotNo [CoreNodeId]
getLeaderSchedule :: Map SlotNo [CoreNodeId]
      }
    deriving stock    (Int -> LeaderSchedule -> ShowS
[LeaderSchedule] -> ShowS
LeaderSchedule -> String
(Int -> LeaderSchedule -> ShowS)
-> (LeaderSchedule -> String)
-> ([LeaderSchedule] -> ShowS)
-> Show LeaderSchedule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LeaderSchedule] -> ShowS
$cshowList :: [LeaderSchedule] -> ShowS
show :: LeaderSchedule -> String
$cshow :: LeaderSchedule -> String
showsPrec :: Int -> LeaderSchedule -> ShowS
$cshowsPrec :: Int -> LeaderSchedule -> ShowS
Show, LeaderSchedule -> LeaderSchedule -> Bool
(LeaderSchedule -> LeaderSchedule -> Bool)
-> (LeaderSchedule -> LeaderSchedule -> Bool) -> Eq LeaderSchedule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LeaderSchedule -> LeaderSchedule -> Bool
$c/= :: LeaderSchedule -> LeaderSchedule -> Bool
== :: LeaderSchedule -> LeaderSchedule -> Bool
$c== :: LeaderSchedule -> LeaderSchedule -> Bool
Eq, Eq LeaderSchedule
Eq LeaderSchedule
-> (LeaderSchedule -> LeaderSchedule -> Ordering)
-> (LeaderSchedule -> LeaderSchedule -> Bool)
-> (LeaderSchedule -> LeaderSchedule -> Bool)
-> (LeaderSchedule -> LeaderSchedule -> Bool)
-> (LeaderSchedule -> LeaderSchedule -> Bool)
-> (LeaderSchedule -> LeaderSchedule -> LeaderSchedule)
-> (LeaderSchedule -> LeaderSchedule -> LeaderSchedule)
-> Ord LeaderSchedule
LeaderSchedule -> LeaderSchedule -> Bool
LeaderSchedule -> LeaderSchedule -> Ordering
LeaderSchedule -> LeaderSchedule -> LeaderSchedule
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LeaderSchedule -> LeaderSchedule -> LeaderSchedule
$cmin :: LeaderSchedule -> LeaderSchedule -> LeaderSchedule
max :: LeaderSchedule -> LeaderSchedule -> LeaderSchedule
$cmax :: LeaderSchedule -> LeaderSchedule -> LeaderSchedule
>= :: LeaderSchedule -> LeaderSchedule -> Bool
$c>= :: LeaderSchedule -> LeaderSchedule -> Bool
> :: LeaderSchedule -> LeaderSchedule -> Bool
$c> :: LeaderSchedule -> LeaderSchedule -> Bool
<= :: LeaderSchedule -> LeaderSchedule -> Bool
$c<= :: LeaderSchedule -> LeaderSchedule -> Bool
< :: LeaderSchedule -> LeaderSchedule -> Bool
$c< :: LeaderSchedule -> LeaderSchedule -> Bool
compare :: LeaderSchedule -> LeaderSchedule -> Ordering
$ccompare :: LeaderSchedule -> LeaderSchedule -> Ordering
$cp1Ord :: Eq LeaderSchedule
Ord, (forall x. LeaderSchedule -> Rep LeaderSchedule x)
-> (forall x. Rep LeaderSchedule x -> LeaderSchedule)
-> Generic LeaderSchedule
forall x. Rep LeaderSchedule x -> LeaderSchedule
forall x. LeaderSchedule -> Rep LeaderSchedule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LeaderSchedule x -> LeaderSchedule
$cfrom :: forall x. LeaderSchedule -> Rep LeaderSchedule x
Generic)
    deriving anyclass (Context -> LeaderSchedule -> IO (Maybe ThunkInfo)
Proxy LeaderSchedule -> String
(Context -> LeaderSchedule -> IO (Maybe ThunkInfo))
-> (Context -> LeaderSchedule -> IO (Maybe ThunkInfo))
-> (Proxy LeaderSchedule -> String)
-> NoThunks LeaderSchedule
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy LeaderSchedule -> String
$cshowTypeOf :: Proxy LeaderSchedule -> String
wNoThunks :: Context -> LeaderSchedule -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LeaderSchedule -> IO (Maybe ThunkInfo)
noThunks :: Context -> LeaderSchedule -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> LeaderSchedule -> IO (Maybe ThunkInfo)
NoThunks)

-- | The 'Slots' a given node is supposed to lead in
leaderScheduleFor :: CoreNodeId -> LeaderSchedule -> Set SlotNo
leaderScheduleFor :: CoreNodeId -> LeaderSchedule -> Set SlotNo
leaderScheduleFor CoreNodeId
nid =
      Map SlotNo [CoreNodeId] -> Set SlotNo
forall k a. Map k a -> Set k
Map.keysSet
    (Map SlotNo [CoreNodeId] -> Set SlotNo)
-> (LeaderSchedule -> Map SlotNo [CoreNodeId])
-> LeaderSchedule
-> Set SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreNodeId] -> Bool)
-> Map SlotNo [CoreNodeId] -> Map SlotNo [CoreNodeId]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (CoreNodeId -> [CoreNodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem CoreNodeId
nid)
    (Map SlotNo [CoreNodeId] -> Map SlotNo [CoreNodeId])
-> (LeaderSchedule -> Map SlotNo [CoreNodeId])
-> LeaderSchedule
-> Map SlotNo [CoreNodeId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeaderSchedule -> Map SlotNo [CoreNodeId]
getLeaderSchedule

instance Semigroup LeaderSchedule where
    LeaderSchedule Map SlotNo [CoreNodeId]
l <> :: LeaderSchedule -> LeaderSchedule -> LeaderSchedule
<> LeaderSchedule Map SlotNo [CoreNodeId]
r =
        Map SlotNo [CoreNodeId] -> LeaderSchedule
LeaderSchedule (Map SlotNo [CoreNodeId] -> LeaderSchedule)
-> Map SlotNo [CoreNodeId] -> LeaderSchedule
forall a b. (a -> b) -> a -> b
$
        ([CoreNodeId] -> [CoreNodeId] -> [CoreNodeId])
-> Map SlotNo [CoreNodeId]
-> Map SlotNo [CoreNodeId]
-> Map SlotNo [CoreNodeId]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [CoreNodeId] -> [CoreNodeId] -> [CoreNodeId]
forall a. Eq a => [a] -> [a] -> [a]
comb Map SlotNo [CoreNodeId]
l Map SlotNo [CoreNodeId]
r
      where
        comb :: [a] -> [a] -> [a]
comb [a]
ls [a]
rs = [a]
ls [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
ls) [a]
rs

instance Condense LeaderSchedule where
    condense :: LeaderSchedule -> String
condense (LeaderSchedule Map SlotNo [CoreNodeId]
m) = [(SlotNo, [NodeId])] -> String
forall a. Condense a => a -> String
condense
                                ([(SlotNo, [NodeId])] -> String) -> [(SlotNo, [NodeId])] -> String
forall a b. (a -> b) -> a -> b
$ ((SlotNo, [CoreNodeId]) -> (SlotNo, [NodeId]))
-> [(SlotNo, [CoreNodeId])] -> [(SlotNo, [NodeId])]
forall a b. (a -> b) -> [a] -> [b]
map (\(SlotNo
s, [CoreNodeId]
ls) -> (SlotNo
s, (CoreNodeId -> NodeId) -> [CoreNodeId] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map CoreNodeId -> NodeId
fromCoreNodeId [CoreNodeId]
ls))
                                ([(SlotNo, [CoreNodeId])] -> [(SlotNo, [NodeId])])
-> [(SlotNo, [CoreNodeId])] -> [(SlotNo, [NodeId])]
forall a b. (a -> b) -> a -> b
$ Map SlotNo [CoreNodeId] -> [(SlotNo, [CoreNodeId])]
forall k a. Map k a -> [(k, a)]
Map.toList Map SlotNo [CoreNodeId]
m

{-------------------------------------------------------------------------------
  ConsensusProtocol instance
-------------------------------------------------------------------------------}

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

-- | Chain selection is unchanged
instance ChainSelection p => ChainSelection (WithLeaderSchedule p) where
  type ChainSelConfig (WithLeaderSchedule p) = ChainSelConfig p
  type SelectView     (WithLeaderSchedule p) = SelectView     p

  preferCandidate :: proxy (WithLeaderSchedule p)
-> ChainSelConfig (WithLeaderSchedule p)
-> SelectView (WithLeaderSchedule p)
-> SelectView (WithLeaderSchedule p)
-> Bool
preferCandidate   proxy (WithLeaderSchedule p)
_ = Proxy p -> ChainSelConfig p -> SelectView p -> SelectView p -> Bool
forall p (proxy :: * -> *).
ChainSelection p =>
proxy p -> ChainSelConfig p -> SelectView p -> SelectView p -> Bool
preferCandidate   (Proxy p
forall k (t :: k). Proxy t
Proxy @p)
  compareCandidates :: proxy (WithLeaderSchedule p)
-> ChainSelConfig (WithLeaderSchedule p)
-> SelectView (WithLeaderSchedule p)
-> SelectView (WithLeaderSchedule p)
-> Ordering
compareCandidates proxy (WithLeaderSchedule p)
_ = Proxy p
-> ChainSelConfig p -> SelectView p -> SelectView p -> Ordering
forall p (proxy :: * -> *).
ChainSelection p =>
proxy p
-> ChainSelConfig p -> SelectView p -> SelectView p -> Ordering
compareCandidates (Proxy p
forall k (t :: k). Proxy t
Proxy @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 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
  chainSelConfig :: ConsensusConfig (WithLeaderSchedule p)
-> ChainSelConfig (WithLeaderSchedule p)
chainSelConfig        = ConsensusConfig p -> ChainSelConfig p
forall p.
ConsensusProtocol p =>
ConsensusConfig p -> ChainSelConfig p
chainSelConfig        (ConsensusConfig p -> ChainSelConfig p)
-> (ConsensusConfig (WithLeaderSchedule p) -> ConsensusConfig p)
-> ConsensusConfig (WithLeaderSchedule p)
-> ChainSelConfig p
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 -> String -> Maybe ()
forall a. HasCallStack => String -> a
error (String -> Maybe ()) -> String -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String
"WithLeaderSchedule: missing slot " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
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))