{-# 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 (..)
  , PBftSelectView (..)
  , PBftSignatureThreshold (..)
  , mkPBftSelectView
  , 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           Codec.Serialise (Serialise (..))
import qualified Control.Exception as Exn
import           Control.Monad (unless)
import           Control.Monad.Except (throwError)
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 {
      -- | The actual issuer of a block
      forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftIssuer    :: VerKeyDSIGN (PBftDSIGN c)
      -- | The stakeholder on whose behalf the block is being issued
    , forall c toSign. PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftGenKey    :: VerKeyDSIGN (PBftDSIGN c)
    , 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
--
-- 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).
data PBftSelectView = PBftSelectView {
      PBftSelectView -> BlockNo
pbftSelectViewBlockNo :: BlockNo
    , PBftSelectView -> IsEBB
pbftSelectViewIsEBB   :: IsEBB
    }
  deriving stock (Int -> PBftSelectView -> ShowS
[PBftSelectView] -> ShowS
PBftSelectView -> String
(Int -> PBftSelectView -> ShowS)
-> (PBftSelectView -> String)
-> ([PBftSelectView] -> ShowS)
-> Show PBftSelectView
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PBftSelectView -> ShowS
showsPrec :: Int -> PBftSelectView -> ShowS
$cshow :: PBftSelectView -> String
show :: PBftSelectView -> String
$cshowList :: [PBftSelectView] -> ShowS
showList :: [PBftSelectView] -> ShowS
Show, PBftSelectView -> PBftSelectView -> Bool
(PBftSelectView -> PBftSelectView -> Bool)
-> (PBftSelectView -> PBftSelectView -> Bool) -> Eq PBftSelectView
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PBftSelectView -> PBftSelectView -> Bool
== :: PBftSelectView -> PBftSelectView -> Bool
$c/= :: PBftSelectView -> PBftSelectView -> Bool
/= :: PBftSelectView -> PBftSelectView -> Bool
Eq, (forall x. PBftSelectView -> Rep PBftSelectView x)
-> (forall x. Rep PBftSelectView x -> PBftSelectView)
-> Generic PBftSelectView
forall x. Rep PBftSelectView x -> PBftSelectView
forall x. PBftSelectView -> Rep PBftSelectView x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PBftSelectView -> Rep PBftSelectView x
from :: forall x. PBftSelectView -> Rep PBftSelectView x
$cto :: forall x. Rep PBftSelectView x -> PBftSelectView
to :: forall x. Rep PBftSelectView x -> PBftSelectView
Generic)
  deriving anyclass (Context -> PBftSelectView -> IO (Maybe ThunkInfo)
Proxy PBftSelectView -> String
(Context -> PBftSelectView -> IO (Maybe ThunkInfo))
-> (Context -> PBftSelectView -> IO (Maybe ThunkInfo))
-> (Proxy PBftSelectView -> String)
-> NoThunks PBftSelectView
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PBftSelectView -> String
showTypeOf :: Proxy PBftSelectView -> String
NoThunks)
  deriving (Ord PBftSelectView
Ord PBftSelectView =>
(ChainOrderConfig PBftSelectView
 -> PBftSelectView -> PBftSelectView -> Bool)
-> ChainOrder PBftSelectView
ChainOrderConfig PBftSelectView
-> PBftSelectView -> PBftSelectView -> Bool
forall sv.
Ord sv =>
(ChainOrderConfig sv -> sv -> sv -> Bool) -> ChainOrder sv
$cpreferCandidate :: ChainOrderConfig PBftSelectView
-> PBftSelectView -> PBftSelectView -> Bool
preferCandidate :: ChainOrderConfig PBftSelectView
-> PBftSelectView -> PBftSelectView -> Bool
ChainOrder) via SimpleChainOrder PBftSelectView

mkPBftSelectView :: GetHeader blk => Header blk -> PBftSelectView
mkPBftSelectView :: forall blk. GetHeader blk => Header blk -> PBftSelectView
mkPBftSelectView Header blk
hdr = PBftSelectView {
      pbftSelectViewBlockNo :: BlockNo
pbftSelectViewBlockNo = Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo       Header blk
hdr
    , pbftSelectViewIsEBB :: IsEBB
pbftSelectViewIsEBB   = Header blk -> IsEBB
forall blk. GetHeader blk => Header blk -> IsEBB
headerToIsEBB Header blk
hdr
    }

instance Ord PBftSelectView where
  compare :: PBftSelectView -> PBftSelectView -> Ordering
compare (PBftSelectView BlockNo
lBlockNo IsEBB
lIsEBB) (PBftSelectView BlockNo
rBlockNo IsEBB
rIsEBB) =
      [Ordering] -> Ordering
forall a. Monoid a => [a] -> a
mconcat [
          -- Prefer the highest block number, as it is a proxy for chain length
          BlockNo
lBlockNo BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` BlockNo
rBlockNo

          -- 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
                     )
                => (VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c))
                -- ^ Construct DSIGN context given 'pbftGenKey'
                -> 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
pbftIsLeaderSignKey :: forall c. PBftIsLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderDlgCert :: forall c. PBftIsLeader c -> PBftDelegationCert 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 {
      -- | ProtocolParameters: map from genesis to delegate keys.
      forall c.
PBftLedgerView c -> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
pbftDelegates :: Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
    }
  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 {
      -- | Security parameter
      --
      -- Although the protocol proper does not have such a security parameter,
      -- we insist on it.
      PBftParams -> SecurityParam
pbftSecurityParam      :: !SecurityParam

      -- | Number of core nodes
    , PBftParams -> NumCoreNodes
pbftNumNodes           :: !NumCoreNodes

      -- | 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@.
    , PBftParams -> PBftSignatureThreshold
pbftSignatureThreshold :: !PBftSignatureThreshold
    }
  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 SelectView    (PBft c) = PBftSelectView

  -- | 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 {
      -- | Window size
      PBftWindowParams -> WindowSize
windowSize :: S.WindowSize

      -- | Threshold (maximum number of slots anyone is allowed to sign)
    , PBftWindowParams -> Word64
threshold  :: Word64
    }

-- | 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 Word64
k) = Word64 -> WindowSize
S.WindowSize 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