{-# LANGUAGE DeriveAnyClass             #-}
{-# 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           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           Cardano.Binary (ToCBOR (..))
import           Cardano.Crypto.DSIGN
import           Cardano.Crypto.Util

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.Util.Condense

import           Ouroboros.Consensus.Storage.Serialisation

{-------------------------------------------------------------------------------
  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 {
      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
showList :: [SimpleBftExt c c'] -> ShowS
$cshowList :: forall c c'. BftCrypto c' => [SimpleBftExt c c'] -> ShowS
show :: SimpleBftExt c c' -> String
$cshow :: forall c c'. BftCrypto c' => SimpleBftExt c c' -> String
showsPrec :: Int -> SimpleBftExt c c' -> ShowS
$cshowsPrec :: forall c c'. BftCrypto c' => Int -> 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
/= :: 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
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
condense :: SimpleBftExt c c' -> String
$ccondense :: forall c c'. BftCrypto c' => 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
showTypeOf :: Proxy (SimpleBftExt c c') -> String
$cshowTypeOf :: forall c c'.
(BftCrypto c', Typeable c) =>
Proxy (SimpleBftExt c c') -> String
wNoThunks :: Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c c'.
(BftCrypto c', Typeable c) =>
Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
noThunks :: Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
$cnoThunks :: forall c c'.
(BftCrypto c', Typeable c) =>
Context -> SimpleBftExt c c' -> IO (Maybe ThunkInfo)
NoThunks)

-- | Part of the block that gets signed
data SignedSimpleBft c c' = SignedSimpleBft {
      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
$cto :: forall c c' x. Rep (SignedSimpleBft c c') x -> SignedSimpleBft c c'
$cfrom :: forall c c' x. SignedSimpleBft c c' -> Rep (SignedSimpleBft c c') x
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 :: SimpleBftBlock c c' -> SimpleBftHeader c c'
_simpleBFtHeader = SimpleBftBlock c c' -> SimpleBftHeader 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 :: LedgerConfig (SimpleBftBlock c c')
-> Ticked (LedgerState (SimpleBftBlock c c'))
-> Ticked (LedgerView (BlockProtocol (SimpleBftBlock c c')))
protocolLedgerView   LedgerConfig (SimpleBftBlock c c')
_ Ticked (LedgerState (SimpleBftBlock c c'))
_ = Ticked ()
Ticked (LedgerView (BlockProtocol (SimpleBftBlock c c')))
TickedTrivial
  ledgerViewForecastAt :: LedgerConfig (SimpleBftBlock c c')
-> LedgerState (SimpleBftBlock c c')
-> Forecast (LedgerView (BlockProtocol (SimpleBftBlock c c')))
ledgerViewForecastAt LedgerConfig (SimpleBftBlock c c')
_   = LedgerState (SimpleBftBlock c c')
-> Forecast (LedgerView (BlockProtocol (SimpleBftBlock c c')))
forall b. GetTip b => b -> 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 :: 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
simpleBody :: forall c ext ext'. SimpleBlock' c ext ext' -> SimpleBody
simpleBody :: SimpleBody
simpleHeader :: Header (SimpleBlock' c (SimpleBftExt c c') ())
simpleHeader :: forall c ext ext'.
SimpleBlock' c ext ext' -> Header (SimpleBlock' c ext ext')
..} ->
    let SimpleHeader{..} = 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 :: forall c c'.
SimpleStdHeader c (SimpleBftExt c c') -> SignedSimpleBft c c'
SignedSimpleBft {
                signedSimpleBft :: SimpleStdHeader c (SimpleBftExt c c')
signedSimpleBft = SimpleStdHeader c (SimpleBftExt c c')
simpleHeaderStd
              }
    in SimpleBlock :: forall c ext ext'.
Header (SimpleBlock' c ext ext')
-> SimpleBody -> SimpleBlock' c ext ext'
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 :: forall c toSign.
BftFields c toSign -> SignedDSIGN (BftDSIGN c) toSign
bftSignature :: SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
..}) = [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 :: Decoder s (SimpleBftExt c c')
decode = do
      SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
bftSignature <- Decoder s (SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c'))
forall v s a. DSIGNAlgorithm v => Decoder s (SignedDSIGN v a)
decodeSignedDSIGN
      SimpleBftExt c c' -> Decoder s (SimpleBftExt c c')
forall (m :: * -> *) a. Monad m => a -> m a
return (SimpleBftExt c c' -> Decoder s (SimpleBftExt c c'))
-> SimpleBftExt c c' -> Decoder s (SimpleBftExt c c')
forall a b. (a -> b) -> a -> b
$ BftFields c' (SignedSimpleBft c c') -> SimpleBftExt c c'
forall c c'.
BftFields c' (SignedSimpleBft c c') -> SimpleBftExt c c'
SimpleBftExt BftFields :: forall c toSign.
SignedDSIGN (BftDSIGN c) toSign -> BftFields c toSign
BftFields{SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
bftSignature :: SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
bftSignature :: SignedDSIGN (BftDSIGN c') (SignedSimpleBft c c')
..}

instance SimpleCrypto c => Serialise (SignedSimpleBft c c')
instance SimpleCrypto c => SignableRepresentation (SignedSimpleBft c c') where
  getSignableRepresentation :: SignedSimpleBft c c' -> ByteString
getSignableRepresentation = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (SignedSimpleBft c c' -> ByteString)
-> SignedSimpleBft c c'
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedSimpleBft c c' -> ByteString
forall a. Serialise a => a -> ByteString
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