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

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

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           Cardano.Crypto.DSIGN

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 {
      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
$cto :: forall c toSign x. Rep (BftFields c toSign) x -> BftFields c toSign
$cfrom :: forall c toSign x. BftFields c toSign -> Rep (BftFields c toSign) x
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 (Proxy (BftFields c)
forall k (t :: k). 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 :: (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 :: ConsensusConfig (Bft c) -> toSign -> BftFields c toSign
forgeBftFields BftConfig{..} 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 :: forall c toSign.
SignedDSIGN (BftDSIGN c) toSign -> BftFields c toSign
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
$cto :: forall x. Rep BftParams x -> BftParams
$cfrom :: forall x. BftParams -> Rep BftParams x
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
showTypeOf :: Proxy BftParams -> String
$cshowTypeOf :: Proxy BftParams -> String
wNoThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> BftParams -> IO (Maybe ThunkInfo)
NoThunks)

-- | (Static) node configuration
data instance ConsensusConfig (Bft c) = BftConfig {
      ConsensusConfig (Bft c) -> BftParams
bftParams  :: !BftParams
    , ConsensusConfig (Bft c) -> SignKeyDSIGN (BftDSIGN c)
bftSignKey :: !(SignKeyDSIGN (BftDSIGN 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
$cto :: forall c x.
Rep (ConsensusConfig (Bft c)) x -> ConsensusConfig (Bft c)
$cfrom :: forall c x.
ConsensusConfig (Bft c) -> Rep (ConsensusConfig (Bft c)) x
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 :: ConsensusConfig (Bft c)
-> CanBeLeader (Bft c)
-> SlotNo
-> Ticked (ChainDepState (Bft c))
-> Maybe (IsLeader (Bft c))
checkIsLeader BftConfig{..} (CoreNodeId 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 (IsLeader (Bft c))
forall a. Maybe a
Nothing
    where
      BftParams{SecurityParam
NumCoreNodes
bftNumNodes :: NumCoreNodes
bftSecurityParam :: SecurityParam
bftNumNodes :: BftParams -> NumCoreNodes
bftSecurityParam :: BftParams -> SecurityParam
..} = BftParams
bftParams
      NumCoreNodes Word64
numCoreNodes = NumCoreNodes
bftNumNodes

  updateChainDepState :: ConsensusConfig (Bft c)
-> ValidateView (Bft c)
-> SlotNo
-> Ticked (ChainDepState (Bft c))
-> Except (ValidationErr (Bft c)) (ChainDepState (Bft c))
updateChainDepState BftConfig{..}
                      (BftValidateView BftFields{..} 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 (m :: * -> *) a. Monad m => a -> m a
return ()
        Left String
err -> BftValidationErr -> ExceptT BftValidationErr Identity ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BftValidationErr -> ExceptT BftValidationErr Identity ())
-> BftValidationErr -> ExceptT BftValidationErr Identity ()
forall a b. (a -> b) -> a -> b
$ String -> BftValidationErr
BftInvalidSignature String
err
    where
      BftParams{SecurityParam
NumCoreNodes
bftNumNodes :: NumCoreNodes
bftSecurityParam :: SecurityParam
bftNumNodes :: BftParams -> NumCoreNodes
bftSecurityParam :: BftParams -> SecurityParam
..} = 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 :: 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)
-> Ticked (LedgerView (Bft c))
-> SlotNo
-> ChainDepState (Bft c)
-> Ticked (ChainDepState (Bft c))
tickChainDepState     ConsensusConfig (Bft c)
_ Ticked (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
showList :: [BftValidationErr] -> ShowS
$cshowList :: [BftValidationErr] -> ShowS
show :: BftValidationErr -> String
$cshow :: BftValidationErr -> String
showsPrec :: Int -> BftValidationErr -> ShowS
$cshowsPrec :: Int -> BftValidationErr -> ShowS
Show, BftValidationErr -> BftValidationErr -> Bool
(BftValidationErr -> BftValidationErr -> Bool)
-> (BftValidationErr -> BftValidationErr -> Bool)
-> Eq BftValidationErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BftValidationErr -> BftValidationErr -> Bool
$c/= :: BftValidationErr -> BftValidationErr -> Bool
== :: BftValidationErr -> BftValidationErr -> Bool
$c== :: 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
$cto :: forall x. Rep BftValidationErr x -> BftValidationErr
$cfrom :: forall x. BftValidationErr -> Rep BftValidationErr x
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
showTypeOf :: Proxy BftValidationErr -> String
$cshowTypeOf :: Proxy BftValidationErr -> String
wNoThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
noThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> BftValidationErr -> IO (Maybe ThunkInfo)
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 :: SignedDSIGN (BftDSIGN c) toSign
bftSignature :: forall c toSign.
BftFields c toSign -> SignedDSIGN (BftDSIGN c) toSign
..} = SignedDSIGN (BftDSIGN c) toSign -> String
forall a. Condense a => a -> String
condense SignedDSIGN (BftDSIGN c) toSign
bftSignature