{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | Test the Praos chain selection rule (with explicit leader schedule)
module Ouroboros.Consensus.Mock.Ledger.Block.PraosRule (
    PraosCryptoUnused
  , SimplePraosRuleBlock
  , SimplePraosRuleExt (..)
  , SimplePraosRuleHeader
  , forgePraosRuleExt
  ) where

import           Codec.Serialise (Serialise (..))
import           Data.Void (Void)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Cardano.Crypto.Hash
import           Cardano.Crypto.KES
import           Cardano.Crypto.VRF

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Mock.Ledger.Block
import           Ouroboros.Consensus.Mock.Ledger.Forge
import           Ouroboros.Consensus.Mock.Node.Abstract
import           Ouroboros.Consensus.Mock.Protocol.LeaderSchedule
import           Ouroboros.Consensus.Mock.Protocol.Praos
import           Ouroboros.Consensus.NodeId (CoreNodeId)
import           Ouroboros.Consensus.Util.Condense

import           Ouroboros.Consensus.Storage.Serialisation

{-------------------------------------------------------------------------------
  Instantiate @ext@
-------------------------------------------------------------------------------}

-- | Simple block extended with the fields required for Praos
--
-- @c@ is crypto used for the block itself
-- With an explicit leader schedule we need no crypto for the consensus protocol.
--
-- This is an example of a block which is /not/ an instance of 'SignedBlock'.
type SimplePraosRuleBlock c = SimpleBlock c SimplePraosRuleExt

-- | Header for Proas
type SimplePraosRuleHeader c = SimpleHeader c SimplePraosRuleExt

-- | Required extension
--
-- The 'WithLeaderSchedule' doesn't require /anything/ in the block header.
-- We add the 'CoreNodeId' just so that we can check that the schedule matches
-- the chain.
newtype SimplePraosRuleExt = SimplePraosRuleExt {
      SimplePraosRuleExt -> CoreNodeId
simplePraosRuleExt :: CoreNodeId
    }
  deriving stock    ((forall x. SimplePraosRuleExt -> Rep SimplePraosRuleExt x)
-> (forall x. Rep SimplePraosRuleExt x -> SimplePraosRuleExt)
-> Generic SimplePraosRuleExt
forall x. Rep SimplePraosRuleExt x -> SimplePraosRuleExt
forall x. SimplePraosRuleExt -> Rep SimplePraosRuleExt x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SimplePraosRuleExt x -> SimplePraosRuleExt
$cfrom :: forall x. SimplePraosRuleExt -> Rep SimplePraosRuleExt x
Generic, Int -> SimplePraosRuleExt -> ShowS
[SimplePraosRuleExt] -> ShowS
SimplePraosRuleExt -> String
(Int -> SimplePraosRuleExt -> ShowS)
-> (SimplePraosRuleExt -> String)
-> ([SimplePraosRuleExt] -> ShowS)
-> Show SimplePraosRuleExt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimplePraosRuleExt] -> ShowS
$cshowList :: [SimplePraosRuleExt] -> ShowS
show :: SimplePraosRuleExt -> String
$cshow :: SimplePraosRuleExt -> String
showsPrec :: Int -> SimplePraosRuleExt -> ShowS
$cshowsPrec :: Int -> SimplePraosRuleExt -> ShowS
Show, SimplePraosRuleExt -> SimplePraosRuleExt -> Bool
(SimplePraosRuleExt -> SimplePraosRuleExt -> Bool)
-> (SimplePraosRuleExt -> SimplePraosRuleExt -> Bool)
-> Eq SimplePraosRuleExt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimplePraosRuleExt -> SimplePraosRuleExt -> Bool
$c/= :: SimplePraosRuleExt -> SimplePraosRuleExt -> Bool
== :: SimplePraosRuleExt -> SimplePraosRuleExt -> Bool
$c== :: SimplePraosRuleExt -> SimplePraosRuleExt -> Bool
Eq)
  deriving newtype  (SimplePraosRuleExt -> String
(SimplePraosRuleExt -> String) -> Condense SimplePraosRuleExt
forall a. (a -> String) -> Condense a
condense :: SimplePraosRuleExt -> String
$ccondense :: SimplePraosRuleExt -> String
Condense)
  deriving anyclass (Context -> SimplePraosRuleExt -> IO (Maybe ThunkInfo)
Proxy SimplePraosRuleExt -> String
(Context -> SimplePraosRuleExt -> IO (Maybe ThunkInfo))
-> (Context -> SimplePraosRuleExt -> IO (Maybe ThunkInfo))
-> (Proxy SimplePraosRuleExt -> String)
-> NoThunks SimplePraosRuleExt
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy SimplePraosRuleExt -> String
$cshowTypeOf :: Proxy SimplePraosRuleExt -> String
wNoThunks :: Context -> SimplePraosRuleExt -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SimplePraosRuleExt -> IO (Maybe ThunkInfo)
noThunks :: Context -> SimplePraosRuleExt -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> SimplePraosRuleExt -> IO (Maybe ThunkInfo)
NoThunks)

type instance BlockProtocol (SimplePraosRuleBlock c) =
    WithLeaderSchedule (Praos PraosCryptoUnused)

-- | Sanity check that block and header type synonyms agree
_simplePraosRuleHeader :: SimplePraosRuleBlock c -> SimplePraosRuleHeader c
_simplePraosRuleHeader :: SimplePraosRuleBlock c -> SimplePraosRuleHeader c
_simplePraosRuleHeader = SimplePraosRuleBlock c -> SimplePraosRuleHeader c
forall c ext ext'.
SimpleBlock' c ext ext' -> Header (SimpleBlock' c ext ext')
simpleHeader

{-------------------------------------------------------------------------------
  Customization of the generic infrastructure
-------------------------------------------------------------------------------}

instance SimpleCrypto c => MockProtocolSpecific c SimplePraosRuleExt where
  type MockLedgerConfig c SimplePraosRuleExt = ()

{-------------------------------------------------------------------------------
  Evidence that 'SimpleBlock' can support Praos with an explicit leader schedule
-------------------------------------------------------------------------------}

instance SimpleCrypto c => RunMockBlock c SimplePraosRuleExt where
  mockNetworkMagic :: BlockConfig (SimpleBlock c SimplePraosRuleExt) -> NetworkMagic
mockNetworkMagic = NetworkMagic
-> BlockConfig (SimpleBlock c SimplePraosRuleExt) -> NetworkMagic
forall a b. a -> b -> a
const NetworkMagic
HasCallStack => NetworkMagic
constructMockNetworkMagic

instance
  ( SimpleCrypto c
  ) => BlockSupportsProtocol (SimpleBlock c SimplePraosRuleExt) where
  validateView :: BlockConfig (SimpleBlock c SimplePraosRuleExt)
-> Header (SimpleBlock c SimplePraosRuleExt)
-> ValidateView (BlockProtocol (SimpleBlock c SimplePraosRuleExt))
validateView BlockConfig (SimpleBlock c SimplePraosRuleExt)
_ Header (SimpleBlock c SimplePraosRuleExt)
_ = ()

instance
  ( SimpleCrypto c
  ) => LedgerSupportsProtocol (SimplePraosRuleBlock c) where
  protocolLedgerView :: LedgerConfig (SimplePraosRuleBlock c)
-> Ticked (LedgerState (SimplePraosRuleBlock c))
-> Ticked (LedgerView (BlockProtocol (SimplePraosRuleBlock c)))
protocolLedgerView   LedgerConfig (SimplePraosRuleBlock c)
_ Ticked (LedgerState (SimplePraosRuleBlock c))
_ = Ticked ()
Ticked (LedgerView (BlockProtocol (SimplePraosRuleBlock c)))
TickedTrivial
  ledgerViewForecastAt :: LedgerConfig (SimplePraosRuleBlock c)
-> LedgerState (SimplePraosRuleBlock c)
-> Forecast (LedgerView (BlockProtocol (SimplePraosRuleBlock c)))
ledgerViewForecastAt LedgerConfig (SimplePraosRuleBlock c)
_   = LedgerState (SimplePraosRuleBlock c)
-> Forecast (LedgerView (BlockProtocol (SimplePraosRuleBlock c)))
forall b. GetTip b => b -> Forecast ()
trivialForecast

{-------------------------------------------------------------------------------
  We don't need crypto for this protocol
-------------------------------------------------------------------------------}

data PraosCryptoUnused

instance PraosCrypto PraosCryptoUnused where
  type PraosKES  PraosCryptoUnused = NeverKES
  type PraosVRF  PraosCryptoUnused = NeverVRF
  type PraosHash PraosCryptoUnused = NeverHash

{-------------------------------------------------------------------------------
  Forging
-------------------------------------------------------------------------------}


type instance CannotForge (SimplePraosRuleBlock c) = Void

type instance ForgeStateInfo (SimplePraosRuleBlock c) = ()

type instance ForgeStateUpdateError (SimplePraosRuleBlock c) = Void

forgePraosRuleExt :: SimpleCrypto c => ForgeExt c SimplePraosRuleExt
forgePraosRuleExt :: ForgeExt c SimplePraosRuleExt
forgePraosRuleExt = (TopLevelConfig (SimpleBlock c SimplePraosRuleExt)
 -> IsLeader (BlockProtocol (SimpleBlock c SimplePraosRuleExt))
 -> SimpleBlock' c SimplePraosRuleExt ()
 -> SimpleBlock c SimplePraosRuleExt)
-> ForgeExt c SimplePraosRuleExt
forall c ext.
(TopLevelConfig (SimpleBlock c ext)
 -> IsLeader (BlockProtocol (SimpleBlock c ext))
 -> SimpleBlock' c ext ()
 -> SimpleBlock c ext)
-> ForgeExt c ext
ForgeExt ((TopLevelConfig (SimpleBlock c SimplePraosRuleExt)
  -> IsLeader (BlockProtocol (SimpleBlock c SimplePraosRuleExt))
  -> SimpleBlock' c SimplePraosRuleExt ()
  -> SimpleBlock c SimplePraosRuleExt)
 -> ForgeExt c SimplePraosRuleExt)
-> (TopLevelConfig (SimpleBlock c SimplePraosRuleExt)
    -> IsLeader (BlockProtocol (SimpleBlock c SimplePraosRuleExt))
    -> SimpleBlock' c SimplePraosRuleExt ()
    -> SimpleBlock c SimplePraosRuleExt)
-> ForgeExt c SimplePraosRuleExt
forall a b. (a -> b) -> a -> b
$ \TopLevelConfig (SimpleBlock c SimplePraosRuleExt)
cfg IsLeader (BlockProtocol (SimpleBlock c SimplePraosRuleExt))
_ SimpleBlock{Header (SimpleBlock' c SimplePraosRuleExt ())
SimpleBody
simpleBody :: forall c ext ext'. SimpleBlock' c ext ext' -> SimpleBody
simpleBody :: SimpleBody
simpleHeader :: Header (SimpleBlock' c SimplePraosRuleExt ())
simpleHeader :: forall c ext ext'.
SimpleBlock' c ext ext' -> Header (SimpleBlock' c ext ext')
..} ->
    let ext :: SimplePraosRuleExt
ext = CoreNodeId -> SimplePraosRuleExt
SimplePraosRuleExt (CoreNodeId -> SimplePraosRuleExt)
-> CoreNodeId -> SimplePraosRuleExt
forall a b. (a -> b) -> a -> b
$ ConsensusConfig (WithLeaderSchedule (Praos PraosCryptoUnused))
-> CoreNodeId
forall p. ConsensusConfig (WithLeaderSchedule p) -> CoreNodeId
wlsConfigNodeId (TopLevelConfig (SimpleBlock c SimplePraosRuleExt)
-> ConsensusConfig
     (BlockProtocol (SimpleBlock c SimplePraosRuleExt))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (SimpleBlock c SimplePraosRuleExt)
cfg)
        SimpleHeader{..} = Header (SimpleBlock' c SimplePraosRuleExt ())
simpleHeader
    in SimpleBlock :: forall c ext ext'.
Header (SimpleBlock' c ext ext')
-> SimpleBody -> SimpleBlock' c ext ext'
SimpleBlock {
        simpleHeader :: Header (SimpleBlock c SimplePraosRuleExt)
simpleHeader = (SimplePraosRuleExt -> Encoding)
-> SimpleStdHeader c SimplePraosRuleExt
-> SimplePraosRuleExt
-> Header (SimpleBlock c SimplePraosRuleExt)
forall c ext' ext.
SimpleCrypto c =>
(ext' -> Encoding)
-> SimpleStdHeader c ext
-> ext'
-> Header (SimpleBlock' c ext ext')
mkSimpleHeader SimplePraosRuleExt -> Encoding
forall a. Serialise a => a -> Encoding
encode SimpleStdHeader c SimplePraosRuleExt
simpleHeaderStd SimplePraosRuleExt
ext
      , simpleBody :: SimpleBody
simpleBody   = SimpleBody
simpleBody
      }

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance Serialise SimplePraosRuleExt

instance EncodeDisk (SimplePraosRuleBlock c) ()
  -- Default instance

instance DecodeDisk (SimplePraosRuleBlock c) ()
  -- Default instance