{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeFamilyDependencies    #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE UndecidableInstances      #-}

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           Codec.Serialise (Serialise (..))
import qualified Control.Exception as Exn
import           Control.Monad.Except
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           Cardano.Crypto.DSIGN.Class

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
      PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftIssuer    :: VerKeyDSIGN (PBftDSIGN c)
      -- | The stakeholder on whose behalf the block is being issued
    , PBftFields c toSign -> VerKeyDSIGN (PBftDSIGN c)
pbftGenKey    :: VerKeyDSIGN (PBftDSIGN c)
    , 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
$cto :: forall c toSign x.
Rep (PBftFields c toSign) x -> PBftFields c toSign
$cfrom :: forall c toSign x.
PBftFields c toSign -> Rep (PBftFields c toSign) x
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 :: 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 :: 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 (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
showList :: [PBftSelectView] -> ShowS
$cshowList :: [PBftSelectView] -> ShowS
show :: PBftSelectView -> String
$cshow :: PBftSelectView -> String
showsPrec :: Int -> PBftSelectView -> ShowS
$cshowsPrec :: Int -> PBftSelectView -> ShowS
Show, PBftSelectView -> PBftSelectView -> Bool
(PBftSelectView -> PBftSelectView -> Bool)
-> (PBftSelectView -> PBftSelectView -> Bool) -> Eq PBftSelectView
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PBftSelectView -> PBftSelectView -> Bool
$c/= :: PBftSelectView -> PBftSelectView -> Bool
== :: PBftSelectView -> PBftSelectView -> Bool
$c== :: 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
$cto :: forall x. Rep PBftSelectView x -> PBftSelectView
$cfrom :: forall x. PBftSelectView -> Rep PBftSelectView x
Generic, 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
showTypeOf :: Proxy PBftSelectView -> String
$cshowTypeOf :: Proxy PBftSelectView -> String
wNoThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> PBftSelectView -> IO (Maybe ThunkInfo)
NoThunks)

mkPBftSelectView :: GetHeader blk => Header blk -> PBftSelectView
mkPBftSelectView :: Header blk -> PBftSelectView
mkPBftSelectView Header blk
hdr = PBftSelectView :: BlockNo -> IsEBB -> PBftSelectView
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 :: (VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c))
-> IsLeader (PBft c) -> toSign -> PBftFields c toSign
forgePBftFields VerKeyDSIGN (PBftDSIGN c) -> ContextDSIGN (PBftDSIGN c)
contextDSIGN PBftIsLeader{..} 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 :: forall c toSign.
VerKeyDSIGN (PBftDSIGN c)
-> VerKeyDSIGN (PBftDSIGN c)
-> SignedDSIGN (PBftDSIGN c) toSign
-> PBftFields c toSign
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.
      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
$cto :: forall c x. Rep (PBftLedgerView c) x -> PBftLedgerView c
$cfrom :: forall c x. PBftLedgerView c -> Rep (PBftLedgerView c) x
Generic)

newtype instance Ticked (PBftLedgerView c) = TickedPBftLedgerView {
      -- | The updated delegates
      Ticked (PBftLedgerView c)
-> Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
tickedPBftDelegates :: Bimap (PBftVerKeyHash c) (PBftVerKeyHash c)
    }

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 :: 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 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
/= :: PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
$c/= :: PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
== :: PBftSignatureThreshold -> PBftSignatureThreshold -> Bool
$c== :: 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
showList :: [PBftSignatureThreshold] -> ShowS
$cshowList :: [PBftSignatureThreshold] -> ShowS
show :: PBftSignatureThreshold -> String
$cshow :: PBftSignatureThreshold -> String
showsPrec :: Int -> PBftSignatureThreshold -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep PBftSignatureThreshold x -> PBftSignatureThreshold
$cfrom :: forall x. PBftSignatureThreshold -> Rep PBftSignatureThreshold x
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
showTypeOf :: Proxy PBftSignatureThreshold -> String
$cshowTypeOf :: Proxy PBftSignatureThreshold -> String
wNoThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> PBftSignatureThreshold -> IO (Maybe ThunkInfo)
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
$cto :: forall x. Rep PBftParams x -> PBftParams
$cfrom :: forall x. PBftParams -> Rep PBftParams x
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
showTypeOf :: Proxy PBftParams -> String
$cshowTypeOf :: Proxy PBftParams -> String
wNoThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> PBftParams -> IO (Maybe ThunkInfo)
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
showList :: [PBftParams] -> ShowS
$cshowList :: [PBftParams] -> ShowS
show :: PBftParams -> String
$cshow :: PBftParams -> String
showsPrec :: Int -> PBftParams -> ShowS
$cshowsPrec :: Int -> 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 {
      PBftCanBeLeader c -> CoreNodeId
pbftCanBeLeaderCoreNodeId :: !CoreNodeId
    , PBftCanBeLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderSignKey    :: !(SignKeyDSIGN (PBftDSIGN 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
$cto :: forall c x. Rep (PBftCanBeLeader c) x -> PBftCanBeLeader c
$cfrom :: forall c x. PBftCanBeLeader c -> Rep (PBftCanBeLeader c) x
Generic)

instance PBftCrypto c => NoThunks (PBftCanBeLeader c)

-- | Information required to produce a block.
data PBftIsLeader c = PBftIsLeader {
      PBftIsLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderSignKey :: !(SignKeyDSIGN (PBftDSIGN 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
$cto :: forall c x. Rep (PBftIsLeader c) x -> PBftIsLeader c
$cfrom :: forall c x. PBftIsLeader c -> Rep (PBftIsLeader c) x
Generic)

instance PBftCrypto c => NoThunks (PBftIsLeader c)

-- | (Static) node configuration
newtype instance ConsensusConfig (PBft c) = PBftConfig {
      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
$cto :: forall c x.
Rep (ConsensusConfig (PBft c)) x -> ConsensusConfig (PBft c)
$cfrom :: forall c x.
ConsensusConfig (PBft c) -> Rep (ConsensusConfig (PBft c)) x
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
showTypeOf :: Proxy (ConsensusConfig (PBft c)) -> String
$cshowTypeOf :: forall c. Proxy (ConsensusConfig (PBft c)) -> String
wNoThunks :: Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c.
Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
noThunks :: Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
$cnoThunks :: forall c.
Context -> ConsensusConfig (PBft c) -> IO (Maybe ThunkInfo)
NoThunks)

-- Ticking has no effect on the PBFtState, but we do need the ticked ledger view
data instance Ticked (PBftState c) = TickedPBftState {
      Ticked (PBftState c) -> Ticked (LedgerView (PBft c))
tickedPBftLedgerView :: Ticked (LedgerView (PBft 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 :: ConsensusConfig (PBft c)
-> CanBeLeader (PBft c)
-> SlotNo
-> Ticked (ChainDepState (PBft c))
-> Maybe (IsLeader (PBft c))
checkIsLeader PBftConfig{pbftParams}
                PBftCanBeLeader{..}
                (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 :: forall c.
SignKeyDSIGN (PBftDSIGN c)
-> PBftDelegationCert c -> PBftIsLeader c
PBftIsLeader {
            pbftIsLeaderSignKey :: SignKeyDSIGN (PBftDSIGN c)
pbftIsLeaderSignKey = SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderSignKey
          , pbftIsLeaderDlgCert :: PBftDelegationCert c
pbftIsLeaderDlgCert = PBftDelegationCert c
pbftCanBeLeaderDlgCert
          }
      else
        Maybe (IsLeader (PBft 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)
-> Ticked (LedgerView (PBft c))
-> SlotNo
-> ChainDepState (PBft c)
-> Ticked (ChainDepState (PBft c))
tickChainDepState ConsensusConfig (PBft c)
_ Ticked (LedgerView (PBft c))
lv SlotNo
_ = Ticked (LedgerView (PBft c)) -> PBftState c -> Ticked (PBftState c)
forall c.
Ticked (LedgerView (PBft c)) -> PBftState c -> Ticked (PBftState c)
TickedPBftState Ticked (LedgerView (PBft c))
lv

  updateChainDepState :: 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 (TickedPBftLedgerView dms) state) =
      case ValidateView (PBft c)
toValidate of
        ValidateView (PBft c)
PBftValidateBoundary ->
          PBftState c -> ExceptT (PBftValidationErr c) Identity (PBftState c)
forall (m :: * -> *) a. Monad m => a -> m a
return PBftState c
state
        PBftValidateRegular PBftFields{..} signed 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 (m :: * -> *) a. Monad m => a -> m a
return ()
            Left String
err -> PBftValidationErr c -> ExceptT (PBftValidationErr c) Identity ()
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 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 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 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 (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 :: 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 (TickedPBftLedgerView dms) state) =
      case ValidateView (PBft c)
toValidate of
        ValidateView (PBft c)
PBftValidateBoundary -> ChainDepState (PBft c)
PBftState c
state
        PBftValidateRegular PBftFields{pbftIssuer} _ _ ->
          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 -> PBftState c
forall a. (?callStack::CallStack) => String -> a
error (String -> PBftState c) -> String -> PBftState 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 -> PBftState c
forall a. (?callStack::CallStack) => String -> a
error (String -> PBftState c) -> String -> PBftState 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 :: ConsensusConfig (PBft c) -> PBftWindowParams
pbftWindowParams PBftConfig{..} = PBftWindowParams :: WindowSize -> Word64 -> PBftWindowParams
PBftWindowParams {
      windowSize :: WindowSize
windowSize = WindowSize
winSize
    , threshold :: Word64
threshold  =
        Double -> Word64
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
pbftNumNodes :: NumCoreNodes
pbftSecurityParam :: SecurityParam
pbftSignatureThreshold :: PBftSignatureThreshold
pbftSignatureThreshold :: PBftParams -> PBftSignatureThreshold
pbftNumNodes :: PBftParams -> NumCoreNodes
pbftSecurityParam :: PBftParams -> SecurityParam
..} = 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 :: PBftWindowParams
-> PBftState c -> PBftVerKeyHash c -> Either Word64 ()
pbftWindowExceedsThreshold PBftWindowParams{Word64
WindowSize
threshold :: Word64
windowSize :: WindowSize
threshold :: PBftWindowParams -> Word64
windowSize :: PBftWindowParams -> WindowSize
..} 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 :: ConsensusConfig (PBft c)
-> PBftWindowParams
-> (SlotNo, PBftVerKeyHash c)
-> PBftState c
-> PBftState c
append PBftConfig{} PBftWindowParams{Word64
WindowSize
threshold :: Word64
windowSize :: WindowSize
threshold :: PBftWindowParams -> Word64
windowSize :: PBftWindowParams -> WindowSize
..} =
    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
$cto :: forall c x. Rep (PBftValidationErr c) x -> PBftValidationErr c
$cfrom :: forall c x. PBftValidationErr c -> Rep (PBftValidationErr c) x
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
showTypeOf :: Proxy (PBftValidationErr c) -> String
$cshowTypeOf :: forall c. PBftCrypto c => Proxy (PBftValidationErr c) -> String
wNoThunks :: Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c.
PBftCrypto c =>
Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
noThunks :: Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
$cnoThunks :: forall c.
PBftCrypto c =>
Context -> PBftValidationErr c -> IO (Maybe ThunkInfo)
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
$cto :: forall c x. Rep (PBftCannotForge c) x -> PBftCannotForge c
$cfrom :: forall c x. PBftCannotForge c -> Rep (PBftCannotForge c) x
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 :: ConsensusConfig (PBft c)
-> PBftCanBeLeader c
-> SlotNo
-> Ticked (PBftState c)
-> Either (PBftCannotForge c) ()
pbftCheckCanForge ConsensusConfig (PBft c)
cfg PBftCanBeLeader{SignKeyDSIGN (PBftDSIGN c)
PBftDelegationCert c
CoreNodeId
pbftCanBeLeaderDlgCert :: PBftDelegationCert c
pbftCanBeLeaderSignKey :: SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderCoreNodeId :: CoreNodeId
pbftCanBeLeaderDlgCert :: forall c. PBftCanBeLeader c -> PBftDelegationCert c
pbftCanBeLeaderSignKey :: forall c. PBftCanBeLeader c -> SignKeyDSIGN (PBftDSIGN c)
pbftCanBeLeaderCoreNodeId :: forall c. PBftCanBeLeader c -> CoreNodeId
..} 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 (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 (TickedPBftLedgerView dms) cds = Ticked (PBftState c)
tickedChainDepState

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

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