{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}

#if __GLASGOW_HASKELL__ >= 908
-- GHC is a bit pickier for data family instances, but trying to remove this
-- one forces us to reorganize the Protocol.* modules. TODO eventually.
{-# OPTIONS_GHC -Wno-orphans #-}
#endif

module Ouroboros.Consensus.Protocol.PBFT
  ( PBft
  , PBftCanBeLeader (..)
  , PBftFields (..)
  , PBftIsLeader (..)
  , PBftLedgerView (..)
  , PBftParams (..)
  , PBftTiebreakerView (..)
  , PBftSignatureThreshold (..)
  , mkPBftTiebreakerView
  , pbftWindowExceedsThreshold
  , pbftWindowSize

    -- * Forging
  , forgePBftFields

    -- * Classes
  , PBftCrypto (..)
  , PBftMockCrypto
  , PBftMockVerKeyHash (..)
  , PBftValidateView (..)
  , pbftValidateBoundary
  , pbftValidateRegular

    -- * CannotForge
  , PBftCannotForge (..)
  , pbftCheckCanForge

    -- * Type instances
  , ConsensusConfig (..)
  , Ticked (..)

    -- * Exported for tracing errors
  , PBftValidationErr (..)
  ) where

import Cardano.Crypto.DSIGN.Class
import Cardano.Ledger.BaseTypes (unNonZero)
import Codec.Serialise (Serialise (..))
import qualified Control.Exception as Exn
import Control.Monad (unless)
import Control.Monad.Except (throwError)
import Control.ResourceRegistry ()
import Data.Bifunctor (first)
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (Typeable)
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId (CoreNodeId (..))
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Protocol.PBFT.Crypto
import Ouroboros.Consensus.Protocol.PBFT.State (PBftState)
import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
import Ouroboros.Consensus.Protocol.Signed
import Ouroboros.Consensus.Ticked
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.Orphans ()

{-------------------------------------------------------------------------------
  Fields that PBFT requires present in a block
-------------------------------------------------------------------------------}

data PBftFields c toSign = PBftFields
  { forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftIssuer :: VerKeyDSIGN (PBftDSIGN c)
  -- ^ The actual issuer of a block
  , forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftGenKey :: VerKeyDSIGN (PBftDSIGN c)
  -- ^ The stakeholder on whose behalf the block is being issued
  , forall c toSign.
PBftFields c toSign -> SignedDSIGN (PBftDSIGN c) toSign
pbftSignature :: SignedDSIGN (PBftDSIGN c) toSign
  }
  deriving (forall x. PBftFields c toSign -> Rep (PBftFields c toSign) x)
-> (forall x. Rep (PBftFields c toSign) x -> PBftFields c toSign)
-> Generic (PBftFields c toSign)
forall x. Rep (PBftFields c toSign) x -> PBftFields c toSign
forall x. PBftFields c toSign -> Rep (PBftFields c toSign) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c toSign x.
Rep (PBftFields c toSign) x -> PBftFields c toSign
forall c toSign x.
PBftFields c toSign -> Rep (PBftFields c toSign) x
$cfrom :: forall c toSign x.
PBftFields c toSign -> Rep (PBftFields c toSign) x
from :: forall x. PBftFields c toSign -> Rep (PBftFields c toSign) x
$cto :: forall c toSign x.
Rep (PBftFields c toSign) x -> PBftFields c toSign
to :: forall x. Rep (PBftFields c toSign) x -> PBftFields c toSign
Generic

deriving instance PBftCrypto c => Show (PBftFields c toSign)
deriving instance PBftCrypto c => Eq (PBftFields c toSign)

instance (PBftCrypto c, Typeable toSign) => NoThunks (PBftFields c toSign)

-- use generic instance

-- | Part of the header that we validate
data PBftValidateView c
  = -- | Regular block
    --
    -- Regular blocks are signed, and so we need to validate them.
    -- We also need to know the slot number of the block
    forall signed.
    Signable (PBftDSIGN c) signed =>
    PBftValidateRegular
      (PBftFields c signed)
      signed
      (ContextDSIGN (PBftDSIGN c))
  | -- | Boundary block (EBB)
    --
    -- EBBs are not signed and they do not affect the consensus state.
    PBftValidateBoundary

-- | Convenience constructor for 'PBftValidateView' for regular blocks
pbftValidateRegular ::
  ( SignedHeader hdr
  , Signable (PBftDSIGN c) (Signed hdr)
  ) =>
  ContextDSIGN (PBftDSIGN c) ->
  (hdr -> PBftFields c (Signed hdr)) ->
  (hdr -> PBftValidateView c)
pbftValidateRegular :: forall hdr c.
(SignedHeader hdr, Signable (PBftDSIGN c) (Signed hdr)) =>
ContextDSIGN (PBftDSIGN c)
-> (hdr -> PBftFields c (Signed hdr)) -> hdr -> PBftValidateView c
pbftValidateRegular ContextDSIGN (PBftDSIGN c)
contextDSIGN hdr -> PBftFields c (Signed hdr)
getFields hdr
hdr =
  PBftFields c (Signed hdr)
-> Signed hdr -> ContextDSIGN (PBftDSIGN c) -> PBftValidateView c
forall c signed.
Signable (PBftDSIGN c) signed =>
PBftFields c signed
-> signed -> ContextDSIGN (PBftDSIGN c) -> PBftValidateView c
PBftValidateRegular
    (hdr -> PBftFields c (Signed hdr)
getFields hdr
hdr)
    (hdr -> Signed hdr
forall hdr. SignedHeader hdr => hdr -> Signed hdr
headerSigned hdr
hdr)
    ContextDSIGN (PBftDSIGN c)
contextDSIGN

-- | Convenience constructor for 'PBftValidateView' for boundary blocks
pbftValidateBoundary :: hdr -> PBftValidateView c
pbftValidateBoundary :: forall hdr c. hdr -> PBftValidateView c
pbftValidateBoundary hdr
_hdr = PBftValidateView c
forall c. PBftValidateView c
PBftValidateBoundary

-- | Part of the header required for chain selection between chains with an
-- equal block number at their tip.
--
-- EBBs share a block number with regular blocks, and so for chain selection
-- we need to know if a block is an EBB or not (because a chain ending on an
-- EBB with a particular block number is longer than a chain on a regular
-- block with that same block number).
newtype PBftTiebreakerView = PBftTiebreakerView
  { PBftTiebreakerView -> IsEBB
pbftTiebreakerViewIsEBB :: IsEBB
  }
  deriving stock (Int -> PBftTiebreakerView -> ShowS
[PBftTiebreakerView] -> ShowS
PBftTiebreakerView -> String
(Int -> PBftTiebreakerView -> ShowS)
-> (PBftTiebreakerView -> String)
-> ([PBftTiebreakerView] -> ShowS)
-> Show PBftTiebreakerView
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PBftTiebreakerView -> ShowS
showsPrec :: Int -> PBftTiebreakerView -> ShowS
$cshow :: PBftTiebreakerView -> String
show :: PBftTiebreakerView -> String
$cshowList :: [PBftTiebreakerView] -> ShowS
showList :: [PBftTiebreakerView] -> ShowS
Show, PBftTiebreakerView -> PBftTiebreakerView -> Bool
(PBftTiebreakerView -> PBftTiebreakerView -> Bool)
-> (PBftTiebreakerView -> PBftTiebreakerView -> Bool)
-> Eq PBftTiebreakerView
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PBftTiebreakerView -> PBftTiebreakerView -> Bool
== :: PBftTiebreakerView -> PBftTiebreakerView -> Bool
$c/= :: PBftTiebreakerView -> PBftTiebreakerView -> Bool
/= :: PBftTiebreakerView -> PBftTiebreakerView -> Bool
Eq, (forall x. PBftTiebreakerView -> Rep PBftTiebreakerView x)
-> (forall x. Rep PBftTiebreakerView x -> PBftTiebreakerView)
-> Generic PBftTiebreakerView
forall x. Rep PBftTiebreakerView x -> PBftTiebreakerView
forall x. PBftTiebreakerView -> Rep PBftTiebreakerView x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PBftTiebreakerView -> Rep PBftTiebreakerView x
from :: forall x. PBftTiebreakerView -> Rep PBftTiebreakerView x
$cto :: forall x. Rep PBftTiebreakerView x -> PBftTiebreakerView
to :: forall x. Rep PBftTiebreakerView x -> PBftTiebreakerView
Generic)
  deriving anyclass Context -> PBftTiebreakerView -> IO (Maybe ThunkInfo)
Proxy PBftTiebreakerView -> String
(Context -> PBftTiebreakerView -> IO (Maybe ThunkInfo))
-> (Context -> PBftTiebreakerView -> IO (Maybe ThunkInfo))
-> (Proxy PBftTiebreakerView -> String)
-> NoThunks PBftTiebreakerView
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PBftTiebreakerView -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftTiebreakerView -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PBftTiebreakerView -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PBftTiebreakerView -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PBftTiebreakerView -> String
showTypeOf :: Proxy PBftTiebreakerView -> String
NoThunks
  deriving Ord PBftTiebreakerView
Ord PBftTiebreakerView =>
(ChainOrderConfig PBftTiebreakerView
 -> PBftTiebreakerView -> PBftTiebreakerView -> Bool)
-> ChainOrder PBftTiebreakerView
ChainOrderConfig PBftTiebreakerView
-> PBftTiebreakerView -> PBftTiebreakerView -> Bool
forall sv.
Ord sv =>
(ChainOrderConfig sv -> sv -> sv -> Bool) -> ChainOrder sv
$cpreferCandidate :: ChainOrderConfig PBftTiebreakerView
-> PBftTiebreakerView -> PBftTiebreakerView -> Bool
preferCandidate :: ChainOrderConfig PBftTiebreakerView
-> PBftTiebreakerView -> PBftTiebreakerView -> Bool
ChainOrder via SimpleChainOrder PBftTiebreakerView

mkPBftTiebreakerView :: GetHeader blk => Header blk -> PBftTiebreakerView
mkPBftTiebreakerView :: forall blk. GetHeader blk => Header blk -> PBftTiebreakerView
mkPBftTiebreakerView Header blk
hdr =
  PBftTiebreakerView
    { pbftTiebreakerViewIsEBB :: IsEBB
pbftTiebreakerViewIsEBB = Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr
    }

instance Ord PBftTiebreakerView where
  compare :: PBftTiebreakerView -> PBftTiebreakerView -> Ordering
compare (PBftTiebreakerView IsEBB
lIsEBB) (PBftTiebreakerView IsEBB
rIsEBB) =
    -- If the block numbers are the same, check if one of them is an EBB.
    -- An EBB has the same block number as the block before it, so the
    -- chain ending with an EBB is actually longer than the one ending
    -- with a regular block.
    IsEBB -> Int
score IsEBB
lIsEBB Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` IsEBB -> Int
score IsEBB
rIsEBB
   where
    score :: IsEBB -> Int
    score :: IsEBB -> Int
score IsEBB
IsEBB = Int
1
    score IsEBB
IsNotEBB = Int
0

{-------------------------------------------------------------------------------
  Block forging
-------------------------------------------------------------------------------}

forgePBftFields ::
  forall c toSign.
  ( PBftCrypto c
  , Signable (PBftDSIGN c) toSign
  ) =>
  -- | Construct DSIGN context given 'pbftGenKey'
  (VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c)) ->
  IsLeader (PBft c) ->
  toSign ->
  PBftFields c toSign
forgePBftFields :: forall c toSign.
(PBftCrypto c, Signable (PBftDSIGN c) toSign) =>
(VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c))
-> IsLeader (PBft c) -> toSign -> PBftFields c toSign
forgePBftFields VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c)
contextDSIGN PBftIsLeader{SignKeyDSIGN (PBftDSIGN c)
PBftDelegationCert c
pbftIsLeaderSignKey :: SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderDlgCert :: PBftDelegationCert c
pbftIsLeaderDlgCert :: forall c. PBftIsLeader c -> PBftDelegationCert c
pbftIsLeaderSignKey :: forall c. PBftIsLeader c -> SignKeyDSIGN (PBftDSIGN c)
..} toSign
toSign =
  Bool -> PBftFields c toSign -> PBftFields c toSign
forall a. (?callStack::CallStack) => Bool -> a -> a
Exn.assert (VerKeyDSIGN (PBftDSIGN c)
issuer VerKeyDSIGN (PBftDSIGN c) -> VerKeyDSIGN (PBftDSIGN c) -> Bool
forall a. Eq a => a -> a -> Bool
== SignKeyDSIGN (PBftDSIGN c) -> VerKeyDSIGN (PBftDSIGN c)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderSignKey) (PBftFields c toSign -> PBftFields c toSign)
-> PBftFields c toSign -> PBftFields c toSign
forall a b. (a -> b) -> a -> b
$
    PBftFields
      { pbftIssuer :: VerKeyDSIGN (PBftDSIGN c)
pbftIssuer = VerKeyDSIGN (PBftDSIGN c)
issuer
      , pbftGenKey :: VerKeyDSIGN (PBftDSIGN c)
pbftGenKey = VerKeyDSIGN (PBftDSIGN c)
genKey
      , pbftSignature :: SignedDSIGN (PBftDSIGN c) toSign
pbftSignature = SignedDSIGN (PBftDSIGN c) toSign
signature
      }
 where
  issuer :: VerKeyDSIGN (PBftDSIGN c)
issuer = PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c)
forall c.
PBftCrypto c =>
PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c)
dlgCertDlgVerKey PBftDelegationCert c
pbftIsLeaderDlgCert
  genKey :: VerKeyDSIGN (PBftDSIGN c)
genKey = PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c)
forall c.
PBftCrypto c =>
PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c)
dlgCertGenVerKey PBftDelegationCert c
pbftIsLeaderDlgCert
  ctxtDSIGN :: ContextDSIGN (PBftDSIGN c)
ctxtDSIGN = VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c)
contextDSIGN VerKeyDSIGN (PBftDSIGN c)
genKey
  signature :: SignedDSIGN (PBftDSIGN c) toSign
signature = ContextDSIGN (PBftDSIGN c)
-> toSign
-> SignKeyDSIGN (PBftDSIGN c)
-> SignedDSIGN (PBftDSIGN c) toSign
forall v a.
(DSIGNAlgorithm v, Signable v a) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SignedDSIGN v a
signedDSIGN ContextDSIGN (PBftDSIGN c)
ctxtDSIGN toSign
toSign SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderSignKey

{-------------------------------------------------------------------------------
  Information PBFT requires from the ledger
-------------------------------------------------------------------------------}

newtype PBftLedgerView c = PBftLedgerView
  { forall c.
PBftLedgerView c -> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
pbftDelegates :: Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
  -- ^ ProtocolParameters: map from genesis to delegate keys.
  }
  deriving (forall x. PBftLedgerView c -> Rep (PBftLedgerView c) x)
-> (forall x. Rep (PBftLedgerView c) x -> PBftLedgerView c)
-> Generic (PBftLedgerView c)
forall x. Rep (PBftLedgerView c) x -> PBftLedgerView c
forall x. PBftLedgerView c -> Rep (PBftLedgerView c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PBftLedgerView c) x -> PBftLedgerView c
forall c x. PBftLedgerView c -> Rep (PBftLedgerView c) x
$cfrom :: forall c x. PBftLedgerView c -> Rep (PBftLedgerView c) x
from :: forall x. PBftLedgerView c -> Rep (PBftLedgerView c) x
$cto :: forall c x. Rep (PBftLedgerView c) x -> PBftLedgerView c
to :: forall x. Rep (PBftLedgerView c) x -> PBftLedgerView c
Generic

deriving instance PBftCrypto c => NoThunks (PBftLedgerView c)

-- use generic instance

deriving instance Eq (PBftVerKeyHash c) => Eq (PBftLedgerView c)
deriving instance Show (PBftVerKeyHash c) => Show (PBftLedgerView c)

instance
  (Serialise (PBftVerKeyHash c), Ord (PBftVerKeyHash c)) =>
  Serialise (PBftLedgerView c)
  where
  encode :: PBftLedgerView c -> Encoding
encode (PBftLedgerView Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
ds) = [(PBftVerKeyHash c, PBftVerKeyHash c)] -> Encoding
forall a. Serialise a => a -> Encoding
encode (Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
-> [(PBftVerKeyHash c, PBftVerKeyHash c)]
forall a b. Bimap a b -> [(a, b)]
Bimap.toList Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
ds)
  decode :: forall s. Decoder s (PBftLedgerView c)
decode = Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c
forall c.
Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c
PBftLedgerView (Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c)
-> ([(PBftVerKeyHash c, PBftVerKeyHash c)]
    -> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c))
-> [(PBftVerKeyHash c, PBftVerKeyHash c)]
-> PBftLedgerView c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PBftVerKeyHash c, PBftVerKeyHash c)]
-> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
Bimap.fromList ([(PBftVerKeyHash c, PBftVerKeyHash c)] -> PBftLedgerView c)
-> Decoder s [(PBftVerKeyHash c, PBftVerKeyHash c)]
-> Decoder s (PBftLedgerView c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [(PBftVerKeyHash c, PBftVerKeyHash c)]
forall s. Decoder s [(PBftVerKeyHash c, PBftVerKeyHash c)]
forall a s. Serialise a => Decoder s a
decode

{-------------------------------------------------------------------------------
  Protocol proper
-------------------------------------------------------------------------------}

-- | Permissive BFT
--
-- As defined in https://hydra.iohk.io/job/Cardano/cardano-ledger-specs/byronChainSpec/latest/download-by-type/doc-pdf/blockchain-spec
data PBft c

-- | Signature threshold. This represents the proportion of blocks in a
-- @pbftSignatureWindow@-sized window which may be signed by any single key.
newtype PBftSignatureThreshold = PBftSignatureThreshold
  { PBftSignatureThreshold -> Double
getPBftSignatureThreshold :: Double
  }
  deriving (PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
(PBftSignatureThreshold -> PBftSignatureThreshold -> Bool)
-> (PBftSignatureThreshold -> PBftSignatureThreshold -> Bool)
-> Eq PBftSignatureThreshold
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
== :: PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
$c/= :: PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
/= :: PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
Eq, Int -> PBftSignatureThreshold -> ShowS
[PBftSignatureThreshold] -> ShowS
PBftSignatureThreshold -> String
(Int -> PBftSignatureThreshold -> ShowS)
-> (PBftSignatureThreshold -> String)
-> ([PBftSignatureThreshold] -> ShowS)
-> Show PBftSignatureThreshold
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PBftSignatureThreshold -> ShowS
showsPrec :: Int -> PBftSignatureThreshold -> ShowS
$cshow :: PBftSignatureThreshold -> String
show :: PBftSignatureThreshold -> String
$cshowList :: [PBftSignatureThreshold] -> ShowS
showList :: [PBftSignatureThreshold] -> ShowS
Show, (forall x. PBftSignatureThreshold -> Rep PBftSignatureThreshold x)
-> (forall x.
    Rep PBftSignatureThreshold x -> PBftSignatureThreshold)
-> Generic PBftSignatureThreshold
forall x. Rep PBftSignatureThreshold x -> PBftSignatureThreshold
forall x. PBftSignatureThreshold -> Rep PBftSignatureThreshold x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PBftSignatureThreshold -> Rep PBftSignatureThreshold x
from :: forall x. PBftSignatureThreshold -> Rep PBftSignatureThreshold x
$cto :: forall x. Rep PBftSignatureThreshold x -> PBftSignatureThreshold
to :: forall x. Rep PBftSignatureThreshold x -> PBftSignatureThreshold
Generic, Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
Proxy PBftSignatureThreshold -> String
(Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo))
-> (Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo))
-> (Proxy PBftSignatureThreshold -> String)
-> NoThunks PBftSignatureThreshold
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PBftSignatureThreshold -> String
showTypeOf :: Proxy PBftSignatureThreshold -> String
NoThunks)

-- | Protocol parameters
data PBftParams = PBftParams
  { PBftParams -> SecurityParam
pbftSecurityParam :: !SecurityParam
  -- ^ Security parameter
  --
  -- Although the protocol proper does not have such a security parameter,
  -- we insist on it.
  , PBftParams -> NumCoreNodes
pbftNumNodes :: !NumCoreNodes
  -- ^ Number of core nodes
  , PBftParams -> PBftSignatureThreshold
pbftSignatureThreshold :: !PBftSignatureThreshold
  -- ^ Signature threshold
  --
  -- This bounds the proportion of the latest 'pbftSecurityParam'-many
  -- blocks which is allowed to be signed by any single key. The protocol
  -- proper is parameterized over the size of this window of recent blocks,
  -- but this implementation follows the specification by fixing that
  -- parameter to the ambient security parameter @k@.
  }
  deriving ((forall x. PBftParams -> Rep PBftParams x)
-> (forall x. Rep PBftParams x -> PBftParams) -> Generic PBftParams
forall x. Rep PBftParams x -> PBftParams
forall x. PBftParams -> Rep PBftParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PBftParams -> Rep PBftParams x
from :: forall x. PBftParams -> Rep PBftParams x
$cto :: forall x. Rep PBftParams x -> PBftParams
to :: forall x. Rep PBftParams x -> PBftParams
Generic, Context -> PBftParams -> IO (Maybe ThunkInfo)
Proxy PBftParams -> String
(Context -> PBftParams -> IO (Maybe ThunkInfo))
-> (Context -> PBftParams -> IO (Maybe ThunkInfo))
-> (Proxy PBftParams -> String)
-> NoThunks PBftParams
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PBftParams -> String
showTypeOf :: Proxy PBftParams -> String
NoThunks, Int -> PBftParams -> ShowS
[PBftParams] -> ShowS
PBftParams -> String
(Int -> PBftParams -> ShowS)
-> (PBftParams -> String)
-> ([PBftParams] -> ShowS)
-> Show PBftParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PBftParams -> ShowS
showsPrec :: Int -> PBftParams -> ShowS
$cshow :: PBftParams -> String
show :: PBftParams -> String
$cshowList :: [PBftParams] -> ShowS
showList :: [PBftParams] -> ShowS
Show)

-- | If we are a core node (i.e. a block producing node) we know which core
-- node we are, and we have the operational key pair and delegation certificate.
data PBftCanBeLeader c = PBftCanBeLeader
  { forall c. PBftCanBeLeader c -> CoreNodeId
pbftCanBeLeaderCoreNodeId :: !CoreNodeId
  , forall c. PBftCanBeLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderSignKey :: !(SignKeyDSIGN (PBftDSIGN c))
  , forall c. PBftCanBeLeader c -> PBftDelegationCert c
pbftCanBeLeaderDlgCert :: !(PBftDelegationCert c)
  }
  deriving (forall x. PBftCanBeLeader c -> Rep (PBftCanBeLeader c) x)
-> (forall x. Rep (PBftCanBeLeader c) x -> PBftCanBeLeader c)
-> Generic (PBftCanBeLeader c)
forall x. Rep (PBftCanBeLeader c) x -> PBftCanBeLeader c
forall x. PBftCanBeLeader c -> Rep (PBftCanBeLeader c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PBftCanBeLeader c) x -> PBftCanBeLeader c
forall c x. PBftCanBeLeader c -> Rep (PBftCanBeLeader c) x
$cfrom :: forall c x. PBftCanBeLeader c -> Rep (PBftCanBeLeader c) x
from :: forall x. PBftCanBeLeader c -> Rep (PBftCanBeLeader c) x
$cto :: forall c x. Rep (PBftCanBeLeader c) x -> PBftCanBeLeader c
to :: forall x. Rep (PBftCanBeLeader c) x -> PBftCanBeLeader c
Generic

instance PBftCrypto c => NoThunks (PBftCanBeLeader c)

-- | Information required to produce a block.
data PBftIsLeader c = PBftIsLeader
  { forall c. PBftIsLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderSignKey :: !(SignKeyDSIGN (PBftDSIGN c))
  , forall c. PBftIsLeader c -> PBftDelegationCert c
pbftIsLeaderDlgCert :: !(PBftDelegationCert c)
  }
  deriving (forall x. PBftIsLeader c -> Rep (PBftIsLeader c) x)
-> (forall x. Rep (PBftIsLeader c) x -> PBftIsLeader c)
-> Generic (PBftIsLeader c)
forall x. Rep (PBftIsLeader c) x -> PBftIsLeader c
forall x. PBftIsLeader c -> Rep (PBftIsLeader c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PBftIsLeader c) x -> PBftIsLeader c
forall c x. PBftIsLeader c -> Rep (PBftIsLeader c) x
$cfrom :: forall c x. PBftIsLeader c -> Rep (PBftIsLeader c) x
from :: forall x. PBftIsLeader c -> Rep (PBftIsLeader c) x
$cto :: forall c x. Rep (PBftIsLeader c) x -> PBftIsLeader c
to :: forall x. Rep (PBftIsLeader c) x -> PBftIsLeader c
Generic

instance PBftCrypto c => NoThunks (PBftIsLeader c)

-- | (Static) node configuration
newtype instance ConsensusConfig (PBft c) = PBftConfig
  { forall c. ConsensusConfig (PBft c) -> PBftParams
pbftParams :: PBftParams
  }
  deriving ((forall x.
 ConsensusConfig (PBft c) -> Rep (ConsensusConfig (PBft c)) x)
-> (forall x.
    Rep (ConsensusConfig (PBft c)) x -> ConsensusConfig (PBft c))
-> Generic (ConsensusConfig (PBft c))
forall x.
Rep (ConsensusConfig (PBft c)) x -> ConsensusConfig (PBft c)
forall x.
ConsensusConfig (PBft c) -> Rep (ConsensusConfig (PBft c)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (ConsensusConfig (PBft c)) x -> ConsensusConfig (PBft c)
forall c x.
ConsensusConfig (PBft c) -> Rep (ConsensusConfig (PBft c)) x
$cfrom :: forall c x.
ConsensusConfig (PBft c) -> Rep (ConsensusConfig (PBft c)) x
from :: forall x.
ConsensusConfig (PBft c) -> Rep (ConsensusConfig (PBft c)) x
$cto :: forall c x.
Rep (ConsensusConfig (PBft c)) x -> ConsensusConfig (PBft c)
to :: forall x.
Rep (ConsensusConfig (PBft c)) x -> ConsensusConfig (PBft c)
Generic, Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
Proxy (ConsensusConfig (PBft c)) -> String
(Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo))
-> (Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo))
-> (Proxy (ConsensusConfig (PBft c)) -> String)
-> NoThunks (ConsensusConfig (PBft c))
forall c.
Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
forall c. Proxy (ConsensusConfig (PBft c)) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall c.
Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
noThunks :: Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c.
Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall c. Proxy (ConsensusConfig (PBft c)) -> String
showTypeOf :: Proxy (ConsensusConfig (PBft c)) -> String
NoThunks)

-- Ticking has no effect on the PBFtState, but we do need the ledger view
data instance Ticked (PBftState c) = TickedPBftState
  { forall c. Ticked (PBftState c) -> LedgerView (PBft c)
getPBftLedgerView :: LedgerView (PBft c)
  , forall c. Ticked (PBftState c) -> PBftState c
getTickedPBftState :: PBftState c
  }

instance PBftCrypto c => ConsensusProtocol (PBft c) where
  type ValidationErr (PBft c) = PBftValidationErr c
  type ValidateView (PBft c) = PBftValidateView c
  type TiebreakerView (PBft c) = PBftTiebreakerView

  -- \| We require two things from the ledger state:
  --
  --   - Protocol parameters, for the signature window and threshold.
  --   - The delegation map.
  type LedgerView (PBft c) = PBftLedgerView c
  type IsLeader (PBft c) = PBftIsLeader c
  type ChainDepState (PBft c) = PBftState c
  type CanBeLeader (PBft c) = PBftCanBeLeader c

  protocolSecurityParam :: ConsensusConfig (PBft c) -> SecurityParam
protocolSecurityParam = PBftParams -> SecurityParam
pbftSecurityParam (PBftParams -> SecurityParam)
-> (ConsensusConfig (PBft c) -> PBftParams)
-> ConsensusConfig (PBft c)
-> SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (PBft c) -> PBftParams
forall c. ConsensusConfig (PBft c) -> PBftParams
pbftParams

  checkIsLeader :: (?callStack::CallStack) =>
ConsensusConfig (PBft c)
-> CanBeLeader (PBft c)
-> SlotNo
-> Ticked (ChainDepState (PBft c))
-> Maybe (IsLeader (PBft c))
checkIsLeader
    PBftConfig{PBftParams
pbftParams :: forall c. ConsensusConfig (PBft c) -> PBftParams
pbftParams :: PBftParams
pbftParams}
    PBftCanBeLeader{SignKeyDSIGN (PBftDSIGN c)
PBftDelegationCert c
CoreNodeId
pbftCanBeLeaderCoreNodeId :: forall c. PBftCanBeLeader c -> CoreNodeId
pbftCanBeLeaderSignKey :: forall c. PBftCanBeLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderDlgCert :: forall c. PBftCanBeLeader c -> PBftDelegationCert c
pbftCanBeLeaderCoreNodeId :: CoreNodeId
pbftCanBeLeaderSignKey :: SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderDlgCert :: PBftDelegationCert c
..}
    (SlotNo Word64
n)
    Ticked (ChainDepState (PBft c))
_tickedChainDepState =
      -- We are the slot leader based on our node index, and the current
      -- slot number. Our node index depends which genesis key has delegated
      -- to us, see 'genesisKeyCoreNodeId'.
      if Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
numCoreNodes Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
i
        then
          PBftIsLeader c -> Maybe (PBftIsLeader c)
forall a. a -> Maybe a
Just
            PBftIsLeader
              { pbftIsLeaderSignKey :: SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderSignKey = SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderSignKey
              , pbftIsLeaderDlgCert :: PBftDelegationCert c
pbftIsLeaderDlgCert = PBftDelegationCert c
pbftCanBeLeaderDlgCert
              }
        else
          Maybe (IsLeader (PBft c))
Maybe (PBftIsLeader c)
forall a. Maybe a
Nothing
     where
      PBftParams{pbftNumNodes :: PBftParams -> NumCoreNodes
pbftNumNodes = NumCoreNodes Word64
numCoreNodes} = PBftParams
pbftParams
      CoreNodeId Word64
i = CoreNodeId
pbftCanBeLeaderCoreNodeId

  tickChainDepState :: ConsensusConfig (PBft c)
-> LedgerView (PBft c)
-> SlotNo
-> ChainDepState (PBft c)
-> Ticked (ChainDepState (PBft c))
tickChainDepState ConsensusConfig (PBft c)
_ LedgerView (PBft c)
lv SlotNo
_ = LedgerView (PBft c) -> PBftState c -> Ticked (PBftState c)
forall c.
LedgerView (PBft c) -> PBftState c -> Ticked (PBftState c)
TickedPBftState LedgerView (PBft c)
lv

  updateChainDepState :: (?callStack::CallStack) =>
ConsensusConfig (PBft c)
-> ValidateView (PBft c)
-> SlotNo
-> Ticked (ChainDepState (PBft c))
-> Except (ValidationErr (PBft c)) (ChainDepState (PBft c))
updateChainDepState
    ConsensusConfig (PBft c)
cfg
    ValidateView (PBft c)
toValidate
    SlotNo
slot
    (TickedPBftState (PBftLedgerView Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms) PBftState c
state) =
      case ValidateView (PBft c)
toValidate of
        ValidateView (PBft c)
PBftValidateView c
PBftValidateBoundary ->
          PBftState c -> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall a. a -> ExceptT (PBftValidationErr c) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return PBftState c
state
        PBftValidateRegular PBftFields{SignedDSIGN (PBftDSIGN c) signed
VerKeyDSIGN (PBftDSIGN c)
pbftIssuer :: forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftGenKey :: forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftSignature :: forall c toSign.
PBftFields c toSign -> SignedDSIGN (PBftDSIGN c) toSign
pbftIssuer :: VerKeyDSIGN (PBftDSIGN c)
pbftGenKey :: VerKeyDSIGN (PBftDSIGN c)
pbftSignature :: SignedDSIGN (PBftDSIGN c) signed
..} signed
signed ContextDSIGN (PBftDSIGN c)
contextDSIGN -> do
          -- Check that the issuer signature verifies, and that it's a delegate of a
          -- genesis key, and that genesis key hasn't voted too many times.
          case ContextDSIGN (PBftDSIGN c)
-> VerKeyDSIGN (PBftDSIGN c)
-> signed
-> SignedDSIGN (PBftDSIGN c) signed
-> Either String ()
forall v a.
(DSIGNAlgorithm v, Signable v a, ?callStack::CallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SignedDSIGN v a -> Either String ()
verifySignedDSIGN
            ContextDSIGN (PBftDSIGN c)
contextDSIGN
            VerKeyDSIGN (PBftDSIGN c)
pbftIssuer
            signed
signed
            SignedDSIGN (PBftDSIGN c) signed
pbftSignature of
            Right () -> () -> ExceptT (PBftValidationErr c) Identity ()
forall a. a -> ExceptT (PBftValidationErr c) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Left String
err -> PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity ()
forall a.
PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity ())
-> PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> PBftValidationErr c
forall c. Text -> PBftValidationErr c
PBftInvalidSignature (String -> Text
Text.pack String
err)

          -- FIXME confirm that non-strict inequality is ok in general.
          -- It's here because EBBs have the same slot as the first block of their
          -- epoch.
          Bool
-> ExceptT (PBftValidationErr c) Identity ()
-> ExceptT (PBftValidationErr c) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= PBftState c -> WithOrigin SlotNo
forall c. PBftState c -> WithOrigin SlotNo
S.lastSignedSlot PBftState c
state) (ExceptT (PBftValidationErr c) Identity ()
 -> ExceptT (PBftValidationErr c) Identity ())
-> ExceptT (PBftValidationErr c) Identity ()
-> ExceptT (PBftValidationErr c) Identity ()
forall a b. (a -> b) -> a -> b
$
            PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity ()
forall a.
PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PBftValidationErr c
forall c. PBftValidationErr c
PBftInvalidSlot

          case PBftVerKeyHash c
-> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
-> Maybe (PBftVerKeyHash c)
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
Bimap.lookupR (VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
hashVerKey VerKeyDSIGN (PBftDSIGN c)
pbftIssuer) Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms of
            Maybe (PBftVerKeyHash c)
Nothing ->
              PBftValidationErr c
-> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall a.
PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PBftValidationErr c
 -> ExceptT (PBftValidationErr c) Identity (PBftState c))
-> PBftValidationErr c
-> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall a b. (a -> b) -> a -> b
$
                PBftVerKeyHash c -> PBftLedgerView c -> PBftValidationErr c
forall c.
PBftVerKeyHash c -> PBftLedgerView c -> PBftValidationErr c
PBftNotGenesisDelegate
                  (VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
hashVerKey VerKeyDSIGN (PBftDSIGN c)
pbftIssuer)
                  (Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c
forall c.
Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c
PBftLedgerView Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms)
            Just PBftVerKeyHash c
gk -> do
              let state' :: PBftState c
state' = ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
forall c.
PBftCrypto c =>
ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
append ConsensusConfig (PBft c)
cfg PBftWindowParams
params (SlotNo
slot, PBftVerKeyHash c
gk) PBftState c
state
              case PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
forall c.
PBftCrypto c =>
PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
pbftWindowExceedsThreshold PBftWindowParams
params PBftState c
state' PBftVerKeyHash c
gk of
                Left Word64
n -> PBftValidationErr c
-> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall a.
PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PBftValidationErr c
 -> ExceptT (PBftValidationErr c) Identity (PBftState c))
-> PBftValidationErr c
-> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall a b. (a -> b) -> a -> b
$ PBftVerKeyHash c -> Word64 -> PBftValidationErr c
forall c. PBftVerKeyHash c -> Word64 -> PBftValidationErr c
PBftExceededSignThreshold PBftVerKeyHash c
gk Word64
n
                Right () -> PBftState c -> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall a. a -> ExceptT (PBftValidationErr c) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PBftState c
 -> ExceptT (PBftValidationErr c) Identity (PBftState c))
-> PBftState c
-> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall a b. (a -> b) -> a -> b
$! PBftState c
state'
     where
      params :: PBftWindowParams
params = ConsensusConfig (PBft c) -> PBftWindowParams
forall c. ConsensusConfig (PBft c) -> PBftWindowParams
pbftWindowParams ConsensusConfig (PBft c)
cfg

  reupdateChainDepState :: (?callStack::CallStack) =>
ConsensusConfig (PBft c)
-> ValidateView (PBft c)
-> SlotNo
-> Ticked (ChainDepState (PBft c))
-> ChainDepState (PBft c)
reupdateChainDepState
    ConsensusConfig (PBft c)
cfg
    ValidateView (PBft c)
toValidate
    SlotNo
slot
    (TickedPBftState (PBftLedgerView Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms) PBftState c
state) =
      case ValidateView (PBft c)
toValidate of
        ValidateView (PBft c)
PBftValidateView c
PBftValidateBoundary -> ChainDepState (PBft c)
PBftState c
state
        PBftValidateRegular PBftFields{VerKeyDSIGN (PBftDSIGN c)
pbftIssuer :: forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftIssuer :: VerKeyDSIGN (PBftDSIGN c)
pbftIssuer} signed
_ ContextDSIGN (PBftDSIGN c)
_ ->
          case PBftVerKeyHash c
-> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
-> Maybe (PBftVerKeyHash c)
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
Bimap.lookupR (VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
hashVerKey VerKeyDSIGN (PBftDSIGN c)
pbftIssuer) Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms of
            Maybe (PBftVerKeyHash c)
Nothing ->
              String -> ChainDepState (PBft c)
forall a. (?callStack::CallStack) => String -> a
error (String -> ChainDepState (PBft c))
-> String -> ChainDepState (PBft c)
forall a b. (a -> b) -> a -> b
$
                PBftValidationErr c -> String
forall a. Show a => a -> String
show (PBftValidationErr c -> String) -> PBftValidationErr c -> String
forall a b. (a -> b) -> a -> b
$
                  PBftVerKeyHash c -> PBftLedgerView c -> PBftValidationErr c
forall c.
PBftVerKeyHash c -> PBftLedgerView c -> PBftValidationErr c
PBftNotGenesisDelegate
                    (VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
hashVerKey VerKeyDSIGN (PBftDSIGN c)
pbftIssuer)
                    (Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c
forall c.
Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c
PBftLedgerView Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms)
            Just PBftVerKeyHash c
gk -> do
              let state' :: PBftState c
state' = ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
forall c.
PBftCrypto c =>
ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
append ConsensusConfig (PBft c)
cfg PBftWindowParams
params (SlotNo
slot, PBftVerKeyHash c
gk) PBftState c
state
              case PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
forall c.
PBftCrypto c =>
PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
pbftWindowExceedsThreshold PBftWindowParams
params PBftState c
state' PBftVerKeyHash c
gk of
                Left Word64
n -> String -> ChainDepState (PBft c)
forall a. (?callStack::CallStack) => String -> a
error (String -> ChainDepState (PBft c))
-> String -> ChainDepState (PBft c)
forall a b. (a -> b) -> a -> b
$ PBftValidationErr c -> String
forall a. Show a => a -> String
show (PBftValidationErr c -> String) -> PBftValidationErr c -> String
forall a b. (a -> b) -> a -> b
$ PBftVerKeyHash c -> Word64 -> PBftValidationErr c
forall c. PBftVerKeyHash c -> Word64 -> PBftValidationErr c
PBftExceededSignThreshold PBftVerKeyHash c
gk Word64
n
                Right () -> ChainDepState (PBft c)
PBftState c
state'
     where
      params :: PBftWindowParams
params = ConsensusConfig (PBft c) -> PBftWindowParams
forall c. ConsensusConfig (PBft c) -> PBftWindowParams
pbftWindowParams ConsensusConfig (PBft c)
cfg

{-------------------------------------------------------------------------------
  Internal: thin wrapper on top of 'PBftState'
-------------------------------------------------------------------------------}

-- | Parameters for the window check
data PBftWindowParams = PBftWindowParams
  { PBftWindowParams -> WindowSize
windowSize :: S.WindowSize
  -- ^ Window size
  , PBftWindowParams -> Word64
threshold :: Word64
  -- ^ Threshold (maximum number of slots anyone is allowed to sign)
  }

-- | Compute window check parameters from the node config
pbftWindowParams :: ConsensusConfig (PBft c) -> PBftWindowParams
pbftWindowParams :: forall c. ConsensusConfig (PBft c) -> PBftWindowParams
pbftWindowParams PBftConfig{PBftParams
pbftParams :: forall c. ConsensusConfig (PBft c) -> PBftParams
pbftParams :: PBftParams
..} =
  PBftWindowParams
    { windowSize :: WindowSize
windowSize = WindowSize
winSize
    , threshold :: Word64
threshold =
        Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Word64) -> Double -> Word64
forall a b. (a -> b) -> a -> b
$
          PBftSignatureThreshold -> Double
getPBftSignatureThreshold PBftSignatureThreshold
pbftSignatureThreshold Double -> Double -> Double
forall a. Num a => a -> a -> a
* WindowSize -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral WindowSize
winSize
    }
 where
  PBftParams{SecurityParam
NumCoreNodes
PBftSignatureThreshold
pbftSecurityParam :: PBftParams -> SecurityParam
pbftNumNodes :: PBftParams -> NumCoreNodes
pbftSignatureThreshold :: PBftParams -> PBftSignatureThreshold
pbftSignatureThreshold :: PBftSignatureThreshold
pbftSecurityParam :: SecurityParam
pbftNumNodes :: NumCoreNodes
..} = PBftParams
pbftParams
  winSize :: WindowSize
winSize = SecurityParam -> WindowSize
pbftWindowSize SecurityParam
pbftSecurityParam

-- | Window size used by PBFT
--
-- We set the window size to be equal to k.
pbftWindowSize :: SecurityParam -> S.WindowSize
pbftWindowSize :: SecurityParam -> WindowSize
pbftWindowSize (SecurityParam NonZero Word64
k) = Word64 -> WindowSize
S.WindowSize (Word64 -> WindowSize) -> Word64 -> WindowSize
forall a b. (a -> b) -> a -> b
$ NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k

-- | Does the number of blocks signed by this key exceed the threshold?
--
-- Returns @Just@ the number of blocks signed if exceeded.
pbftWindowExceedsThreshold ::
  PBftCrypto c =>
  PBftWindowParams ->
  PBftState c ->
  PBftVerKeyHash c ->
  Either Word64 ()
pbftWindowExceedsThreshold :: forall c.
PBftCrypto c =>
PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
pbftWindowExceedsThreshold PBftWindowParams{Word64
WindowSize
windowSize :: PBftWindowParams -> WindowSize
threshold :: PBftWindowParams -> Word64
windowSize :: WindowSize
threshold :: Word64
..} PBftState c
st PBftVerKeyHash c
gk =
  if Word64
numSigned Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
threshold
    then Word64 -> Either Word64 ()
forall a b. a -> Either a b
Left Word64
numSigned
    else () -> Either Word64 ()
forall a b. b -> Either a b
Right ()
 where
  numSigned :: Word64
numSigned = PBftState c -> PBftVerKeyHash c -> Word64
forall c. PBftCrypto c => PBftState c -> PBftVerKeyHash c -> Word64
S.countSignedBy PBftState c
st PBftVerKeyHash c
gk

append ::
  PBftCrypto c =>
  ConsensusConfig (PBft c) ->
  PBftWindowParams ->
  (SlotNo, PBftVerKeyHash c) ->
  PBftState c ->
  PBftState c
append :: forall c.
PBftCrypto c =>
ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
append PBftConfig{} PBftWindowParams{Word64
WindowSize
windowSize :: PBftWindowParams -> WindowSize
threshold :: PBftWindowParams -> Word64
windowSize :: WindowSize
threshold :: Word64
..} =
  WindowSize -> PBftSigner c -> PBftState c -> PBftState c
forall c.
PBftCrypto c =>
WindowSize -> PBftSigner c -> PBftState c -> PBftState c
S.append WindowSize
windowSize (PBftSigner c -> PBftState c -> PBftState c)
-> ((SlotNo, PBftVerKeyHash c) -> PBftSigner c)
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo -> PBftVerKeyHash c -> PBftSigner c)
-> (SlotNo, PBftVerKeyHash c) -> PBftSigner c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SlotNo -> PBftVerKeyHash c -> PBftSigner c
forall c. SlotNo -> PBftVerKeyHash c -> PBftSigner c
S.PBftSigner

{-------------------------------------------------------------------------------
  PBFT specific types
-------------------------------------------------------------------------------}

-- | NOTE: this type is stored in the state, so it must be in normal form to
-- avoid space leaks.
data PBftValidationErr c
  = PBftInvalidSignature !Text
  | PBftNotGenesisDelegate !(PBftVerKeyHash c) !(PBftLedgerView c)
  | -- | We record how many slots this key signed
    PBftExceededSignThreshold !(PBftVerKeyHash c) !Word64
  | PBftInvalidSlot
  deriving ((forall x. PBftValidationErr c -> Rep (PBftValidationErr c) x)
-> (forall x. Rep (PBftValidationErr c) x -> PBftValidationErr c)
-> Generic (PBftValidationErr c)
forall x. Rep (PBftValidationErr c) x -> PBftValidationErr c
forall x. PBftValidationErr c -> Rep (PBftValidationErr c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PBftValidationErr c) x -> PBftValidationErr c
forall c x. PBftValidationErr c -> Rep (PBftValidationErr c) x
$cfrom :: forall c x. PBftValidationErr c -> Rep (PBftValidationErr c) x
from :: forall x. PBftValidationErr c -> Rep (PBftValidationErr c) x
$cto :: forall c x. Rep (PBftValidationErr c) x -> PBftValidationErr c
to :: forall x. Rep (PBftValidationErr c) x -> PBftValidationErr c
Generic, Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
Proxy (PBftValidationErr c) -> String
(Context -> PBftValidationErr c -> IO (Maybe ThunkInfo))
-> (Context -> PBftValidationErr c -> IO (Maybe ThunkInfo))
-> (Proxy (PBftValidationErr c) -> String)
-> NoThunks (PBftValidationErr c)
forall c.
PBftCrypto c =>
Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
forall c. PBftCrypto c => Proxy (PBftValidationErr c) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall c.
PBftCrypto c =>
Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c.
PBftCrypto c =>
Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall c. PBftCrypto c => Proxy (PBftValidationErr c) -> String
showTypeOf :: Proxy (PBftValidationErr c) -> String
NoThunks)

deriving instance PBftCrypto c => Show (PBftValidationErr c)
deriving instance PBftCrypto c => Eq (PBftValidationErr c)

{-------------------------------------------------------------------------------
  CannotForge
-------------------------------------------------------------------------------}

-- | Expresses that, whilst we believe ourselves to be a leader for this slot,
-- we are nonetheless unable to forge a block.
data PBftCannotForge c
  = -- | We cannot forge a block because we are not the current delegate of the
    -- genesis key we have a delegation certificate from.
    PBftCannotForgeInvalidDelegation !(PBftVerKeyHash c)
  | -- | We cannot lead because delegates of the genesis key we have a
    -- delegation from have already forged the maximum number of blocks in this
    -- signing window.
    PBftCannotForgeThresholdExceeded !Word64
  deriving (forall x. PBftCannotForge c -> Rep (PBftCannotForge c) x)
-> (forall x. Rep (PBftCannotForge c) x -> PBftCannotForge c)
-> Generic (PBftCannotForge c)
forall x. Rep (PBftCannotForge c) x -> PBftCannotForge c
forall x. PBftCannotForge c -> Rep (PBftCannotForge c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PBftCannotForge c) x -> PBftCannotForge c
forall c x. PBftCannotForge c -> Rep (PBftCannotForge c) x
$cfrom :: forall c x. PBftCannotForge c -> Rep (PBftCannotForge c) x
from :: forall x. PBftCannotForge c -> Rep (PBftCannotForge c) x
$cto :: forall c x. Rep (PBftCannotForge c) x -> PBftCannotForge c
to :: forall x. Rep (PBftCannotForge c) x -> PBftCannotForge c
Generic

deriving instance PBftCrypto c => Show (PBftCannotForge c)

instance PBftCrypto c => NoThunks (PBftCannotForge c)

-- use generic instance

pbftCheckCanForge ::
  forall c.
  PBftCrypto c =>
  ConsensusConfig (PBft c) ->
  PBftCanBeLeader c ->
  SlotNo ->
  Ticked (PBftState c) ->
  Either (PBftCannotForge c) ()
pbftCheckCanForge :: forall c.
PBftCrypto c =>
ConsensusConfig (PBft c)
-> PBftCanBeLeader c
-> SlotNo
-> Ticked (PBftState c)
-> Either (PBftCannotForge c) ()
pbftCheckCanForge ConsensusConfig (PBft c)
cfg PBftCanBeLeader{SignKeyDSIGN (PBftDSIGN c)
PBftDelegationCert c
CoreNodeId
pbftCanBeLeaderCoreNodeId :: forall c. PBftCanBeLeader c -> CoreNodeId
pbftCanBeLeaderSignKey :: forall c. PBftCanBeLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderDlgCert :: forall c. PBftCanBeLeader c -> PBftDelegationCert c
pbftCanBeLeaderCoreNodeId :: CoreNodeId
pbftCanBeLeaderSignKey :: SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderDlgCert :: PBftDelegationCert c
..} SlotNo
slot Ticked (PBftState c)
tickedChainDepState =
  case PBftVerKeyHash c
-> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
-> Maybe (PBftVerKeyHash c)
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
Bimap.lookupR PBftVerKeyHash c
dlgKeyHash Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms of
    Maybe (PBftVerKeyHash c)
Nothing -> PBftCannotForge c -> Either (PBftCannotForge c) ()
forall a b. a -> Either a b
Left (PBftCannotForge c -> Either (PBftCannotForge c) ())
-> PBftCannotForge c -> Either (PBftCannotForge c) ()
forall a b. (a -> b) -> a -> b
$ PBftVerKeyHash c -> PBftCannotForge c
forall c. PBftVerKeyHash c -> PBftCannotForge c
PBftCannotForgeInvalidDelegation PBftVerKeyHash c
dlgKeyHash
    Just PBftVerKeyHash c
gk ->
      (Word64 -> PBftCannotForge c)
-> Either Word64 () -> Either (PBftCannotForge c) ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Word64 -> PBftCannotForge c
forall c. Word64 -> PBftCannotForge c
PBftCannotForgeThresholdExceeded (Either Word64 () -> Either (PBftCannotForge c) ())
-> Either Word64 () -> Either (PBftCannotForge c) ()
forall a b. (a -> b) -> a -> b
$
        PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
forall c.
PBftCrypto c =>
PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
pbftWindowExceedsThreshold PBftWindowParams
params (ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
forall c.
PBftCrypto c =>
ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
append ConsensusConfig (PBft c)
cfg PBftWindowParams
params (SlotNo
slot, PBftVerKeyHash c
gk) PBftState c
cds) PBftVerKeyHash c
gk
 where
  params :: PBftWindowParams
params = ConsensusConfig (PBft c) -> PBftWindowParams
forall c. ConsensusConfig (PBft c) -> PBftWindowParams
pbftWindowParams ConsensusConfig (PBft c)
cfg

  dlgKeyHash :: PBftVerKeyHash c
  dlgKeyHash :: PBftVerKeyHash c
dlgKeyHash = VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
hashVerKey (VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c)
-> (PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c))
-> PBftDelegationCert c
-> PBftVerKeyHash c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c)
forall c.
PBftCrypto c =>
PBftDelegationCert c -> VerKeyDSIGN (PBftDSIGN c)
dlgCertDlgVerKey (PBftDelegationCert c -> PBftVerKeyHash c)
-> PBftDelegationCert c -> PBftVerKeyHash c
forall a b. (a -> b) -> a -> b
$ PBftDelegationCert c
pbftCanBeLeaderDlgCert

  TickedPBftState (PBftLedgerView Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
dms) PBftState c
cds = Ticked (PBftState c)
tickedChainDepState

{-------------------------------------------------------------------------------
  Condense
-------------------------------------------------------------------------------}

instance PBftCrypto c => Condense (PBftFields c toSign) where
  condense :: PBftFields c toSign -> String
condense PBftFields{SignedDSIGN (PBftDSIGN c) toSign
VerKeyDSIGN (PBftDSIGN c)
pbftIssuer :: forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftGenKey :: forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftSignature :: forall c toSign.
PBftFields c toSign -> SignedDSIGN (PBftDSIGN c) toSign
pbftIssuer :: VerKeyDSIGN (PBftDSIGN c)
pbftGenKey :: VerKeyDSIGN (PBftDSIGN c)
pbftSignature :: SignedDSIGN (PBftDSIGN c) toSign
..} = SignedDSIGN (PBftDSIGN c) toSign -> String
forall a. Condense a => a -> String
condense SignedDSIGN (PBftDSIGN c) toSign
pbftSignature