{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Mock.Ledger.Block.BFT
  ( SignedSimpleBft (..)
  , SimpleBftBlock
  , SimpleBftExt (..)
  , SimpleBftHeader
  , forgeBftExt
  ) where

import Cardano.Binary (ToCBOR (..))
import Cardano.Crypto.DSIGN
import Cardano.Crypto.Util
import Codec.Serialise (Serialise (..), serialise)
import qualified Data.ByteString.Lazy as BSL
import Data.Typeable (Typeable)
import Data.Void (Void)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
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.Protocol.BFT
import Ouroboros.Consensus.Protocol.Signed
import Ouroboros.Consensus.Storage.Serialisation
import Ouroboros.Consensus.Util.Condense

{-------------------------------------------------------------------------------
  Instantiate the @ext@ to suit BFT
-------------------------------------------------------------------------------}

-- | Simple block extended with the fields required for BFT
--
-- @c@  is crypto used for the block itself
-- @c'@ is crypto used for the consensus protocol
type SimpleBftBlock c c' = SimpleBlock c (SimpleBftExt c c')

-- | Header for BFT
type SimpleBftHeader c c' = SimpleHeader c (SimpleBftExt c c')

-- | Block extension required for BFT
newtype SimpleBftExt c c' = SimpleBftExt
  { forall c c'.
SimpleBftExt c c' -> BftFields c' (SignedSimpleBft c c')
simpleBftExt :: BftFields c' (SignedSimpleBft c c')
  }
  deriving stock (Int -> SimpleBftExt c c' -> ShowS
[SimpleBftExt c c'] -> ShowS
SimpleBftExt c c' -> String
(Int -> SimpleBftExt c c' -> ShowS)
-> (SimpleBftExt c c' -> String)
-> ([SimpleBftExt c c'] -> ShowS)
-> Show (SimpleBftExt c c')
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall c c'. BftCrypto c' => Int -> SimpleBftExt c c' -> ShowS
forall c c'. BftCrypto c' => [SimpleBftExt c c'] -> ShowS
forall c c'. BftCrypto c' => SimpleBftExt c c' -> String
$cshowsPrec :: forall c c'. BftCrypto c' => Int -> SimpleBftExt c c' -> ShowS
showsPrec :: Int -> SimpleBftExt c c' -> ShowS
$cshow :: forall c c'. BftCrypto c' => SimpleBftExt c c' -> String
show :: SimpleBftExt c c' -> String
$cshowList :: forall c c'. BftCrypto c' => [SimpleBftExt c c'] -> ShowS
showList :: [SimpleBftExt c c'] -> ShowS
Show, SimpleBftExt c c' -> SimpleBftExt c c' -> Bool
(SimpleBftExt c c' -> SimpleBftExt c c' -> Bool)
-> (SimpleBftExt c c' -> SimpleBftExt c c' -> Bool)
-> Eq (SimpleBftExt c c')
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c c'.
BftCrypto c' =>
SimpleBftExt c c' -> SimpleBftExt c c' -> Bool
$c== :: forall c c'.
BftCrypto c' =>
SimpleBftExt c c' -> SimpleBftExt c c' -> Bool
== :: SimpleBftExt c c' -> SimpleBftExt c c' -> Bool
$c/= :: forall c c'.
BftCrypto c' =>
SimpleBftExt c c' -> SimpleBftExt c c' -> Bool
/= :: SimpleBftExt c c' -> SimpleBftExt c c' -> Bool
Eq)
  deriving newtype (SimpleBftExt c c' -> String
(SimpleBftExt c c' -> String) -> Condense (SimpleBftExt c c')
forall a. (a -> String) -> Condense a
forall c c'. BftCrypto c' => SimpleBftExt c c' -> String
$ccondense :: forall c c'. BftCrypto c' => SimpleBftExt c c' -> String
condense :: SimpleBftExt c c' -> String
Condense, Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
Proxy (SimpleBftExt c c') -> String
(Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo))
-> (Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo))
-> (Proxy (SimpleBftExt c c') -> String)
-> NoThunks (SimpleBftExt c c')
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall c c'.
(BftCrypto c', Typeable c) =>
Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
forall c c'.
(BftCrypto c', Typeable c) =>
Proxy (SimpleBftExt c c') -> String
$cnoThunks :: forall c c'.
(BftCrypto c', Typeable c) =>
Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
noThunks :: Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c c'.
(BftCrypto c', Typeable c) =>
Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall c c'.
(BftCrypto c', Typeable c) =>
Proxy (SimpleBftExt c c') -> String
showTypeOf :: Proxy (SimpleBftExt c c') -> String
NoThunks)

-- | Part of the block that gets signed
data SignedSimpleBft c c' = SignedSimpleBft
  { forall c c'.
SignedSimpleBft c c' -> SimpleStdHeader c (SimpleBftExt c c')
signedSimpleBft :: SimpleStdHeader c (SimpleBftExt c c')
  }
  deriving (forall x. SignedSimpleBft c c' -> Rep (SignedSimpleBft c c') x)
-> (forall x. Rep (SignedSimpleBft c c') x -> SignedSimpleBft c c')
-> Generic (SignedSimpleBft c c')
forall x. Rep (SignedSimpleBft c c') x -> SignedSimpleBft c c'
forall x. SignedSimpleBft c c' -> Rep (SignedSimpleBft c c') x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c c' x. Rep (SignedSimpleBft c c') x -> SignedSimpleBft c c'
forall c c' x. SignedSimpleBft c c' -> Rep (SignedSimpleBft c c') x
$cfrom :: forall c c' x. SignedSimpleBft c c' -> Rep (SignedSimpleBft c c') x
from :: forall x. SignedSimpleBft c c' -> Rep (SignedSimpleBft c c') x
$cto :: forall c c' x. Rep (SignedSimpleBft c c') x -> SignedSimpleBft c c'
to :: forall x. Rep (SignedSimpleBft c c') x -> SignedSimpleBft c c'
Generic

type instance BlockProtocol (SimpleBftBlock c c') = Bft c'

-- | Sanity check that block and header type synonyms agree
_simpleBFtHeader :: SimpleBftBlock c c' -> SimpleBftHeader c c'
_simpleBFtHeader :: forall c c'. SimpleBftBlock c c' -> SimpleBftHeader c c'
_simpleBFtHeader = SimpleBlock' c (SimpleBftExt c c') (SimpleBftExt c c')
-> Header (SimpleBlock' c (SimpleBftExt c c') (SimpleBftExt c c'))
forall c ext ext'.
SimpleBlock' c ext ext' -> Header (SimpleBlock' c ext ext')
simpleHeader

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

instance
  (SimpleCrypto c, Typeable c') =>
  MockProtocolSpecific c (SimpleBftExt c c')
  where
  type MockLedgerConfig c (SimpleBftExt c c') = ()

{-------------------------------------------------------------------------------
  Evidence that SimpleBlock can support BFT
-------------------------------------------------------------------------------}

type instance Signed (SimpleBftHeader c c') = SignedSimpleBft c c'

instance SignedHeader (SimpleBftHeader c c') where
  headerSigned :: SimpleBftHeader c c' -> Signed (SimpleBftHeader c c')
headerSigned = SimpleStdHeader c (SimpleBftExt c c') -> SignedSimpleBft c c'
forall c c'.
SimpleStdHeader c (SimpleBftExt c c') -> SignedSimpleBft c c'
SignedSimpleBft (SimpleStdHeader c (SimpleBftExt c c') -> SignedSimpleBft c c')
-> (SimpleBftHeader c c' -> SimpleStdHeader c (SimpleBftExt c c'))
-> SimpleBftHeader c c'
-> SignedSimpleBft c c'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleBftHeader c c' -> SimpleStdHeader c (SimpleBftExt c c')
forall c ext ext'.
Header (SimpleBlock' c ext ext') -> SimpleStdHeader c ext
simpleHeaderStd

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

instance
  ( SimpleCrypto c
  , BftCrypto c'
  , Signable (BftDSIGN c') (SignedSimpleBft c c')
  ) =>
  BlockSupportsProtocol (SimpleBftBlock c c')
  where
  validateView :: BlockConfig (SimpleBftBlock c c')
-> Header (SimpleBftBlock c c')
-> ValidateView (BlockProtocol (SimpleBftBlock c c'))
validateView BlockConfig (SimpleBftBlock c c')
_ = (Header (SimpleBftBlock c c')
 -> BftFields c' (Signed (Header (SimpleBftBlock c c'))))
-> Header (SimpleBftBlock c c') -> BftValidateView c'
forall hdr c.
(SignedHeader hdr, Signable (BftDSIGN c) (Signed hdr)) =>
(hdr -> BftFields c (Signed hdr)) -> hdr -> BftValidateView c
bftValidateView (SimpleBftExt c c' -> BftFields c' (SignedSimpleBft c c')
forall c c'.
SimpleBftExt c c' -> BftFields c' (SignedSimpleBft c c')
simpleBftExt (SimpleBftExt c c' -> BftFields c' (SignedSimpleBft c c'))
-> (Header (SimpleBftBlock c c') -> SimpleBftExt c c')
-> Header (SimpleBftBlock c c')
-> BftFields c' (SignedSimpleBft c c')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (SimpleBftBlock c c') -> SimpleBftExt c c'
forall c ext ext'. Header (SimpleBlock' c ext ext') -> ext'
simpleHeaderExt)

instance
  ( SimpleCrypto c
  , BftCrypto c'
  , Signable (BftDSIGN c') (SignedSimpleBft c c')
  ) =>
  LedgerSupportsProtocol (SimpleBftBlock c c')
  where
  protocolLedgerView :: forall (mk :: * -> * -> *).
LedgerConfig (SimpleBftBlock c c')
-> Ticked (LedgerState (SimpleBftBlock c c')) mk
-> LedgerView (BlockProtocol (SimpleBftBlock c c'))
protocolLedgerView LedgerConfig (SimpleBftBlock c c')
_ Ticked (LedgerState (SimpleBftBlock c c')) mk
_ = ()
  ledgerViewForecastAt :: forall (mk :: * -> * -> *).
HasCallStack =>
LedgerConfig (SimpleBftBlock c c')
-> LedgerState (SimpleBftBlock c c') mk
-> Forecast (LedgerView (BlockProtocol (SimpleBftBlock c c')))
ledgerViewForecastAt LedgerConfig (SimpleBftBlock c c')
_ = LedgerState (SimpleBftBlock c c') mk -> Forecast ()
LedgerState (SimpleBftBlock c c') mk
-> Forecast (LedgerView (BlockProtocol (SimpleBftBlock c c')))
forall (b :: (* -> * -> *) -> *) (mk :: * -> * -> *).
GetTip b =>
b mk -> Forecast ()
trivialForecast

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

type instance CannotForge (SimpleBftBlock c c') = Void

type instance ForgeStateInfo (SimpleBftBlock c c') = ()

type instance ForgeStateUpdateError (SimpleBftBlock c c') = Void

forgeBftExt ::
  forall c c'.
  ( SimpleCrypto c
  , BftCrypto c'
  , Signable (BftDSIGN c') (SignedSimpleBft c c')
  ) =>
  ForgeExt c (SimpleBftExt c c')
forgeBftExt :: forall c c'.
(SimpleCrypto c, BftCrypto c',
 Signable (BftDSIGN c') (SignedSimpleBft c c')) =>
ForgeExt c (SimpleBftExt c c')
forgeBftExt = (TopLevelConfig (SimpleBlock c (SimpleBftExt c c'))
 -> IsLeader (BlockProtocol (SimpleBlock c (SimpleBftExt c c')))
 -> SimpleBlock' c (SimpleBftExt c c') ()
 -> SimpleBlock c (SimpleBftExt c c'))
-> ForgeExt c (SimpleBftExt c c')
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 (SimpleBftExt c c'))
  -> IsLeader (BlockProtocol (SimpleBlock c (SimpleBftExt c c')))
  -> SimpleBlock' c (SimpleBftExt c c') ()
  -> SimpleBlock c (SimpleBftExt c c'))
 -> ForgeExt c (SimpleBftExt c c'))
-> (TopLevelConfig (SimpleBlock c (SimpleBftExt c c'))
    -> IsLeader (BlockProtocol (SimpleBlock c (SimpleBftExt c c')))
    -> SimpleBlock' c (SimpleBftExt c c') ()
    -> SimpleBlock c (SimpleBftExt c c'))
-> ForgeExt c (SimpleBftExt c c')
forall a b. (a -> b) -> a -> b
$ \TopLevelConfig (SimpleBlock c (SimpleBftExt c c'))
cfg IsLeader (BlockProtocol (SimpleBlock c (SimpleBftExt c c')))
_ SimpleBlock{Header (SimpleBlock' c (SimpleBftExt c c') ())
SimpleBody
simpleHeader :: forall c ext ext'.
SimpleBlock' c ext ext' -> Header (SimpleBlock' c ext ext')
simpleHeader :: Header (SimpleBlock' c (SimpleBftExt c c') ())
simpleBody :: SimpleBody
simpleBody :: forall c ext ext'. SimpleBlock' c ext ext' -> SimpleBody
..} ->
  let SimpleHeader{()
HeaderHash (SimpleBlock' c (SimpleBftExt c c') ())
SimpleStdHeader c (SimpleBftExt c c')
simpleHeaderStd :: forall c ext ext'.
Header (SimpleBlock' c ext ext') -> SimpleStdHeader c ext
simpleHeaderExt :: forall c ext ext'. Header (SimpleBlock' c ext ext') -> ext'
simpleHeaderHash :: HeaderHash (SimpleBlock' c (SimpleBftExt c c') ())
simpleHeaderStd :: SimpleStdHeader c (SimpleBftExt c c')
simpleHeaderExt :: ()
simpleHeaderHash :: forall c ext ext'.
Header (SimpleBlock' c ext ext')
-> HeaderHash (SimpleBlock' c ext ext')
..} = Header (SimpleBlock' c (SimpleBftExt c c') ())
simpleHeader
      ext :: SimpleBftExt c c'
      ext :: SimpleBftExt c c'
ext =
        BftFields c' (SignedSimpleBft c c') -> SimpleBftExt c c'
forall c c'.
BftFields c' (SignedSimpleBft c c') -> SimpleBftExt c c'
SimpleBftExt (BftFields c' (SignedSimpleBft c c') -> SimpleBftExt c c')
-> BftFields c' (SignedSimpleBft c c') -> SimpleBftExt c c'
forall a b. (a -> b) -> a -> b
$
          ConsensusConfig (Bft c')
-> SignedSimpleBft c c' -> BftFields c' (SignedSimpleBft c c')
forall c toSign.
(BftCrypto c, Signable (BftDSIGN c) toSign) =>
ConsensusConfig (Bft c) -> toSign -> BftFields c toSign
forgeBftFields (TopLevelConfig (SimpleBlock c (SimpleBftExt c c'))
-> ConsensusConfig
     (BlockProtocol (SimpleBlock c (SimpleBftExt c c')))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (SimpleBlock c (SimpleBftExt c c'))
cfg) (SignedSimpleBft c c' -> BftFields c' (SignedSimpleBft c c'))
-> SignedSimpleBft c c' -> BftFields c' (SignedSimpleBft c c')
forall a b. (a -> b) -> a -> b
$
            SignedSimpleBft
              { signedSimpleBft :: SimpleStdHeader c (SimpleBftExt c c')
signedSimpleBft = SimpleStdHeader c (SimpleBftExt c c')
simpleHeaderStd
              }
   in SimpleBlock
        { simpleHeader :: Header (SimpleBlock c (SimpleBftExt c c'))
simpleHeader = (SimpleBftExt c c' -> Encoding)
-> SimpleStdHeader c (SimpleBftExt c c')
-> SimpleBftExt c c'
-> Header (SimpleBlock c (SimpleBftExt c c'))
forall c ext' ext.
SimpleCrypto c =>
(ext' -> Encoding)
-> SimpleStdHeader c ext
-> ext'
-> Header (SimpleBlock' c ext ext')
mkSimpleHeader SimpleBftExt c c' -> Encoding
forall a. Serialise a => a -> Encoding
encode SimpleStdHeader c (SimpleBftExt c c')
simpleHeaderStd SimpleBftExt c c'
ext
        , simpleBody :: SimpleBody
simpleBody = SimpleBody
simpleBody
        }

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

instance BftCrypto c' => Serialise (SimpleBftExt c c') where
  encode :: SimpleBftExt c c' -> Encoding
encode (SimpleBftExt BftFields{SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
bftSignature :: SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
bftSignature :: forall c toSign.
BftFields c toSign -> SignedDSIGN (BftDSIGN c) toSign
..}) =
    [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
      [ SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c') -> Encoding
forall v a. DSIGNAlgorithm v => SignedDSIGN v a -> Encoding
encodeSignedDSIGN SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
bftSignature
      ]
  decode :: forall s. Decoder s (SimpleBftExt c c')
decode = do
    bftSignature <- Decoder s (SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c'))
forall v s a. DSIGNAlgorithm v => Decoder s (SignedDSIGN v a)
decodeSignedDSIGN
    return $ SimpleBftExt BftFields{..}

instance SimpleCrypto c => Serialise (SignedSimpleBft c c')
instance SimpleCrypto c => SignableRepresentation (SignedSimpleBft c c') where
  getSignableRepresentation :: SignedSimpleBft c c' -> ByteString
getSignableRepresentation = LazyByteString -> ByteString
BSL.toStrict (LazyByteString -> ByteString)
-> (SignedSimpleBft c c' -> LazyByteString)
-> SignedSimpleBft c c'
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedSimpleBft c c' -> LazyByteString
forall a. Serialise a => a -> LazyByteString
serialise

instance (Typeable c', SimpleCrypto c) => ToCBOR (SignedSimpleBft c c') where
  toCBOR :: SignedSimpleBft c c' -> Encoding
toCBOR = SignedSimpleBft c c' -> Encoding
forall a. Serialise a => a -> Encoding
encode

instance EncodeDisk (SimpleBftBlock c c') ()

-- Default instance

instance DecodeDisk (SimpleBftBlock c c') ()

-- Default instance