{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Ouroboros.Consensus.Protocol.BFT (
    Bft
  , BftFields (..)
  , BftParams (..)
  , BftValidationErr (..)
  , forgeBftFields
    -- * Classes
  , BftCrypto (..)
  , BftMockCrypto
  , BftStandardCrypto
  , BftValidateView (..)
  , bftValidateView
    -- * Type instances
  , ConsensusConfig (..)
  ) where

import           Cardano.Crypto.DSIGN
import           Control.Monad.Except
import           Data.Kind (Type)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Proxy
import           Data.Typeable
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks (..))
import           Ouroboros.Consensus.Block.Abstract
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId (CoreNodeId (..), NodeId (..))
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Protocol.Signed
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util.Condense

{-------------------------------------------------------------------------------
  Fields BFT requires in a block
-------------------------------------------------------------------------------}

data BftFields c toSign = BftFields {
      forall c toSign.
BftFields c toSign -> SignedDSIGN (BftDSIGN c) toSign
bftSignature :: !(SignedDSIGN (BftDSIGN c) toSign)
    }
  deriving ((forall x. BftFields c toSign -> Rep (BftFields c toSign) x)
-> (forall x. Rep (BftFields c toSign) x -> BftFields c toSign)
-> Generic (BftFields c toSign)
forall x. Rep (BftFields c toSign) x -> BftFields c toSign
forall x. BftFields c toSign -> Rep (BftFields c toSign) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c toSign x. Rep (BftFields c toSign) x -> BftFields c toSign
forall c toSign x. BftFields c toSign -> Rep (BftFields c toSign) x
$cfrom :: forall c toSign x. BftFields c toSign -> Rep (BftFields c toSign) x
from :: forall x. BftFields c toSign -> Rep (BftFields c toSign) x
$cto :: forall c toSign x. Rep (BftFields c toSign) x -> BftFields c toSign
to :: forall x. Rep (BftFields c toSign) x -> BftFields c toSign
Generic)

deriving instance BftCrypto c => Show (BftFields c toSign)
deriving instance BftCrypto c => Eq   (BftFields c toSign)

-- We use the generic implementation, but override 'showTypeOf' to show @c@
instance (BftCrypto c, Typeable toSign) => NoThunks (BftFields c toSign) where
  showTypeOf :: Proxy (BftFields c toSign) -> String
showTypeOf Proxy (BftFields c toSign)
_ = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy (BftFields c) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @(BftFields c))

data BftValidateView c =
    forall signed. Signable (BftDSIGN c) signed
                => BftValidateView (BftFields c signed) signed

-- | Convenience constructor for 'BftValidateView'
bftValidateView :: ( SignedHeader hdr
                   , Signable (BftDSIGN c) (Signed hdr)
                   )
                => (hdr -> BftFields c (Signed hdr))
                -> (hdr -> BftValidateView c)
bftValidateView :: forall hdr c.
(SignedHeader hdr, Signable (BftDSIGN c) (Signed hdr)) =>
(hdr -> BftFields c (Signed hdr)) -> hdr -> BftValidateView c
bftValidateView hdr -> BftFields c (Signed hdr)
getFields hdr
hdr =
    BftFields c (Signed hdr) -> Signed hdr -> BftValidateView c
forall c signed.
Signable (BftDSIGN c) signed =>
BftFields c signed -> signed -> BftValidateView c
BftValidateView (hdr -> BftFields c (Signed hdr)
getFields hdr
hdr) (hdr -> Signed hdr
forall hdr. SignedHeader hdr => hdr -> Signed hdr
headerSigned hdr
hdr)

forgeBftFields :: ( BftCrypto c
                  , Signable (BftDSIGN c) toSign
                  )
               => ConsensusConfig (Bft c)
               -> toSign
               -> BftFields c toSign
forgeBftFields :: forall c toSign.
(BftCrypto c, Signable (BftDSIGN c) toSign) =>
ConsensusConfig (Bft c) -> toSign -> BftFields c toSign
forgeBftFields BftConfig{Map NodeId (VerKeyDSIGN (BftDSIGN c))
SignKeyDSIGN (BftDSIGN c)
BftParams
bftParams :: BftParams
bftSignKey :: SignKeyDSIGN (BftDSIGN c)
bftVerKeys :: Map NodeId (VerKeyDSIGN (BftDSIGN c))
bftParams :: forall c. ConsensusConfig (Bft c) -> BftParams
bftSignKey :: forall c. ConsensusConfig (Bft c) -> SignKeyDSIGN (BftDSIGN c)
bftVerKeys :: forall c.
ConsensusConfig (Bft c) -> Map NodeId (VerKeyDSIGN (BftDSIGN c))
..} toSign
toSign = let
      signature :: SignedDSIGN (BftDSIGN c) toSign
signature = ContextDSIGN (BftDSIGN c)
-> toSign
-> SignKeyDSIGN (BftDSIGN c)
-> SignedDSIGN (BftDSIGN c) toSign
forall v a.
(DSIGNAlgorithm v, Signable v a) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SignedDSIGN v a
signedDSIGN () toSign
toSign SignKeyDSIGN (BftDSIGN c)
bftSignKey
      in BftFields {
          bftSignature :: SignedDSIGN (BftDSIGN c) toSign
bftSignature = SignedDSIGN (BftDSIGN c) toSign
signature
        }

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

-- | Basic BFT
--
-- Basic BFT is very simple:
--
-- * No support for delegation (and hence has no need for a ledger view)
-- * Requires round-robin block signing throughout (and so has no
--   need for any chain state or cryptographic leader proofs).
-- * Does not use any stateful crypto (and so has no need for node state)
data Bft c

-- | Protocol parameters
data BftParams = BftParams {
      -- | Security parameter
      --
      -- Although the protocol proper does not have such a security parameter,
      -- we insist on it.
      BftParams -> SecurityParam
bftSecurityParam :: !SecurityParam

      -- | Number of core nodes
    , BftParams -> NumCoreNodes
bftNumNodes      :: !NumCoreNodes
    }
  deriving ((forall x. BftParams -> Rep BftParams x)
-> (forall x. Rep BftParams x -> BftParams) -> Generic BftParams
forall x. Rep BftParams x -> BftParams
forall x. BftParams -> Rep BftParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BftParams -> Rep BftParams x
from :: forall x. BftParams -> Rep BftParams x
$cto :: forall x. Rep BftParams x -> BftParams
to :: forall x. Rep BftParams x -> BftParams
Generic, Context -> BftParams -> IO (Maybe ThunkInfo)
Proxy BftParams -> String
(Context -> BftParams -> IO (Maybe ThunkInfo))
-> (Context -> BftParams -> IO (Maybe ThunkInfo))
-> (Proxy BftParams -> String)
-> NoThunks BftParams
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy BftParams -> String
showTypeOf :: Proxy BftParams -> String
NoThunks)

-- | (Static) node configuration
data instance ConsensusConfig (Bft c) = BftConfig {
      forall c. ConsensusConfig (Bft c) -> BftParams
bftParams  :: !BftParams
    , forall c. ConsensusConfig (Bft c) -> SignKeyDSIGN (BftDSIGN c)
bftSignKey :: !(SignKeyDSIGN (BftDSIGN c))
    , forall c.
ConsensusConfig (Bft c) -> Map NodeId (VerKeyDSIGN (BftDSIGN c))
bftVerKeys :: !(Map NodeId (VerKeyDSIGN (BftDSIGN c)))
    }
  deriving ((forall x.
 ConsensusConfig (Bft c) -> Rep (ConsensusConfig (Bft c)) x)
-> (forall x.
    Rep (ConsensusConfig (Bft c)) x -> ConsensusConfig (Bft c))
-> Generic (ConsensusConfig (Bft c))
forall x.
Rep (ConsensusConfig (Bft c)) x -> ConsensusConfig (Bft c)
forall x.
ConsensusConfig (Bft c) -> Rep (ConsensusConfig (Bft c)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (ConsensusConfig (Bft c)) x -> ConsensusConfig (Bft c)
forall c x.
ConsensusConfig (Bft c) -> Rep (ConsensusConfig (Bft c)) x
$cfrom :: forall c x.
ConsensusConfig (Bft c) -> Rep (ConsensusConfig (Bft c)) x
from :: forall x.
ConsensusConfig (Bft c) -> Rep (ConsensusConfig (Bft c)) x
$cto :: forall c x.
Rep (ConsensusConfig (Bft c)) x -> ConsensusConfig (Bft c)
to :: forall x.
Rep (ConsensusConfig (Bft c)) x -> ConsensusConfig (Bft c)
Generic)

instance BftCrypto c => ConsensusProtocol (Bft c) where
  type ValidationErr (Bft c) = BftValidationErr
  type ValidateView  (Bft c) = BftValidateView c
  type LedgerView    (Bft c) = ()
  type IsLeader      (Bft c) = ()
  type ChainDepState (Bft c) = ()
  type CanBeLeader   (Bft c) = CoreNodeId

  protocolSecurityParam :: ConsensusConfig (Bft c) -> SecurityParam
protocolSecurityParam = BftParams -> SecurityParam
bftSecurityParam (BftParams -> SecurityParam)
-> (ConsensusConfig (Bft c) -> BftParams)
-> ConsensusConfig (Bft c)
-> SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (Bft c) -> BftParams
forall c. ConsensusConfig (Bft c) -> BftParams
bftParams

  checkIsLeader :: HasCallStack =>
ConsensusConfig (Bft c)
-> CanBeLeader (Bft c)
-> SlotNo
-> Ticked (ChainDepState (Bft c))
-> Maybe (IsLeader (Bft c))
checkIsLeader BftConfig{Map NodeId (VerKeyDSIGN (BftDSIGN c))
SignKeyDSIGN (BftDSIGN c)
BftParams
bftParams :: forall c. ConsensusConfig (Bft c) -> BftParams
bftSignKey :: forall c. ConsensusConfig (Bft c) -> SignKeyDSIGN (BftDSIGN c)
bftVerKeys :: forall c.
ConsensusConfig (Bft c) -> Map NodeId (VerKeyDSIGN (BftDSIGN c))
bftParams :: BftParams
bftSignKey :: SignKeyDSIGN (BftDSIGN c)
bftVerKeys :: Map NodeId (VerKeyDSIGN (BftDSIGN c))
..} (CoreNodeId Word64
i) (SlotNo Word64
n) Ticked (ChainDepState (Bft c))
_ =
      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 () -> Maybe ()
forall a. a -> Maybe a
Just ()
      else Maybe ()
Maybe (IsLeader (Bft c))
forall a. Maybe a
Nothing
    where
      BftParams{SecurityParam
NumCoreNodes
bftSecurityParam :: BftParams -> SecurityParam
bftNumNodes :: BftParams -> NumCoreNodes
bftSecurityParam :: SecurityParam
bftNumNodes :: NumCoreNodes
..} = BftParams
bftParams
      NumCoreNodes Word64
numCoreNodes = NumCoreNodes
bftNumNodes

  updateChainDepState :: HasCallStack =>
ConsensusConfig (Bft c)
-> ValidateView (Bft c)
-> SlotNo
-> Ticked (ChainDepState (Bft c))
-> Except (ValidationErr (Bft c)) (ChainDepState (Bft c))
updateChainDepState BftConfig{Map NodeId (VerKeyDSIGN (BftDSIGN c))
SignKeyDSIGN (BftDSIGN c)
BftParams
bftParams :: forall c. ConsensusConfig (Bft c) -> BftParams
bftSignKey :: forall c. ConsensusConfig (Bft c) -> SignKeyDSIGN (BftDSIGN c)
bftVerKeys :: forall c.
ConsensusConfig (Bft c) -> Map NodeId (VerKeyDSIGN (BftDSIGN c))
bftParams :: BftParams
bftSignKey :: SignKeyDSIGN (BftDSIGN c)
bftVerKeys :: Map NodeId (VerKeyDSIGN (BftDSIGN c))
..}
                      (BftValidateView BftFields{SignedDSIGN (BftDSIGN c) signed
bftSignature :: forall c toSign.
BftFields c toSign -> SignedDSIGN (BftDSIGN c) toSign
bftSignature :: SignedDSIGN (BftDSIGN c) signed
..} signed
signed)
                      (SlotNo Word64
n)
                      Ticked (ChainDepState (Bft c))
_ =
      -- TODO: Should deal with unknown node IDs
      case ContextDSIGN (BftDSIGN c)
-> VerKeyDSIGN (BftDSIGN c)
-> signed
-> SignedDSIGN (BftDSIGN c) signed
-> Either String ()
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SignedDSIGN v a -> Either String ()
verifySignedDSIGN
             ()
             (Map NodeId (VerKeyDSIGN (BftDSIGN c))
bftVerKeys Map NodeId (VerKeyDSIGN (BftDSIGN c))
-> NodeId -> VerKeyDSIGN (BftDSIGN c)
forall k a. Ord k => Map k a -> k -> a
Map.! NodeId
expectedLeader)
             signed
signed
             SignedDSIGN (BftDSIGN c) signed
bftSignature of
        Right () -> () -> ExceptT BftValidationErr Identity ()
forall a. a -> ExceptT BftValidationErr Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left String
err -> BftValidationErr
-> Except (ValidationErr (Bft c)) (ChainDepState (Bft c))
forall a.
BftValidationErr -> ExceptT (ValidationErr (Bft c)) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BftValidationErr
 -> Except (ValidationErr (Bft c)) (ChainDepState (Bft c)))
-> BftValidationErr
-> Except (ValidationErr (Bft c)) (ChainDepState (Bft c))
forall a b. (a -> b) -> a -> b
$ String -> BftValidationErr
BftInvalidSignature String
err
    where
      BftParams{SecurityParam
NumCoreNodes
bftSecurityParam :: BftParams -> SecurityParam
bftNumNodes :: BftParams -> NumCoreNodes
bftSecurityParam :: SecurityParam
bftNumNodes :: NumCoreNodes
..} = BftParams
bftParams
      expectedLeader :: NodeId
expectedLeader = CoreNodeId -> NodeId
CoreId (CoreNodeId -> NodeId) -> CoreNodeId -> NodeId
forall a b. (a -> b) -> a -> b
$ Word64 -> CoreNodeId
CoreNodeId (Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
numCoreNodes)
      NumCoreNodes Word64
numCoreNodes = NumCoreNodes
bftNumNodes

  reupdateChainDepState :: HasCallStack =>
ConsensusConfig (Bft c)
-> ValidateView (Bft c)
-> SlotNo
-> Ticked (ChainDepState (Bft c))
-> ChainDepState (Bft c)
reupdateChainDepState ConsensusConfig (Bft c)
_ ValidateView (Bft c)
_ SlotNo
_ Ticked (ChainDepState (Bft c))
_ = ()
  tickChainDepState :: ConsensusConfig (Bft c)
-> LedgerView (Bft c)
-> SlotNo
-> ChainDepState (Bft c)
-> Ticked (ChainDepState (Bft c))
tickChainDepState     ConsensusConfig (Bft c)
_ LedgerView (Bft c)
_ SlotNo
_ ChainDepState (Bft c)
_ = Ticked ()
Ticked (ChainDepState (Bft c))
TickedTrivial

instance BftCrypto c => NoThunks (ConsensusConfig (Bft c))
  -- use generic instance

{-------------------------------------------------------------------------------
  BFT specific types
-------------------------------------------------------------------------------}

data BftValidationErr = BftInvalidSignature String
  deriving (Int -> BftValidationErr -> ShowS
[BftValidationErr] -> ShowS
BftValidationErr -> String
(Int -> BftValidationErr -> ShowS)
-> (BftValidationErr -> String)
-> ([BftValidationErr] -> ShowS)
-> Show BftValidationErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BftValidationErr -> ShowS
showsPrec :: Int -> BftValidationErr -> ShowS
$cshow :: BftValidationErr -> String
show :: BftValidationErr -> String
$cshowList :: [BftValidationErr] -> ShowS
showList :: [BftValidationErr] -> ShowS
Show, BftValidationErr -> BftValidationErr -> Bool
(BftValidationErr -> BftValidationErr -> Bool)
-> (BftValidationErr -> BftValidationErr -> Bool)
-> Eq BftValidationErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BftValidationErr -> BftValidationErr -> Bool
== :: BftValidationErr -> BftValidationErr -> Bool
$c/= :: BftValidationErr -> BftValidationErr -> Bool
/= :: BftValidationErr -> BftValidationErr -> Bool
Eq, (forall x. BftValidationErr -> Rep BftValidationErr x)
-> (forall x. Rep BftValidationErr x -> BftValidationErr)
-> Generic BftValidationErr
forall x. Rep BftValidationErr x -> BftValidationErr
forall x. BftValidationErr -> Rep BftValidationErr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BftValidationErr -> Rep BftValidationErr x
from :: forall x. BftValidationErr -> Rep BftValidationErr x
$cto :: forall x. Rep BftValidationErr x -> BftValidationErr
to :: forall x. Rep BftValidationErr x -> BftValidationErr
Generic, Context -> BftValidationErr -> IO (Maybe ThunkInfo)
Proxy BftValidationErr -> String
(Context -> BftValidationErr -> IO (Maybe ThunkInfo))
-> (Context -> BftValidationErr -> IO (Maybe ThunkInfo))
-> (Proxy BftValidationErr -> String)
-> NoThunks BftValidationErr
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
noThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy BftValidationErr -> String
showTypeOf :: Proxy BftValidationErr -> String
NoThunks)

{-------------------------------------------------------------------------------
  Crypto models
-------------------------------------------------------------------------------}

-- | Crypto primitives required by BFT
class ( Typeable c
      , DSIGNAlgorithm (BftDSIGN c)
      , Condense (SigDSIGN (BftDSIGN c))
      , NoThunks (SigDSIGN (BftDSIGN c))
      , ContextDSIGN (BftDSIGN c) ~ ()
      ) => BftCrypto c where
  type family BftDSIGN c :: Type

data BftStandardCrypto
data BftMockCrypto

instance BftCrypto BftStandardCrypto where
  type BftDSIGN BftStandardCrypto = Ed448DSIGN

instance BftCrypto BftMockCrypto where
  type BftDSIGN BftMockCrypto = MockDSIGN

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

instance BftCrypto c => Condense (BftFields c toSign) where
  condense :: BftFields c toSign -> String
condense BftFields{SignedDSIGN (BftDSIGN c) toSign
bftSignature :: forall c toSign.
BftFields c toSign -> SignedDSIGN (BftDSIGN c) toSign
bftSignature :: SignedDSIGN (BftDSIGN c) toSign
..} = SignedDSIGN (BftDSIGN c) toSign -> String
forall a. Condense a => a -> String
condense SignedDSIGN (BftDSIGN c) toSign
bftSignature