{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Node.DiffusionPipelining (
    HotIdentity (..)
  , ShelleyTentativeHeaderState (..)
  , ShelleyTentativeHeaderView (..)
  ) where

import qualified Cardano.Ledger.Shelley.API as SL
import           Control.Monad (guard)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Consensus.Shelley.Ledger.Protocol ()
import           Ouroboros.Consensus.Shelley.Protocol.Abstract

-- | Hot block issuer identity for the purpose of Shelley block diffusion
-- pipelining.
data HotIdentity c = HotIdentity {
    -- | Hash of the cold key.
    forall c. HotIdentity c -> KeyHash 'BlockIssuer c
hiIssuer  :: !(SL.KeyHash SL.BlockIssuer c)
  , -- | The issue number/opcert counter. Even if the opcert was compromised and
    -- hence an attacker forges blocks with a specific cold identity, the owner
    -- of the cold key can issue a new opcert with an incremented counter, and
    -- their minted blocks will be pipelined.
    forall c. HotIdentity c -> Word64
hiIssueNo :: !Word64
  }
  deriving stock (Int -> HotIdentity c -> ShowS
[HotIdentity c] -> ShowS
HotIdentity c -> String
(Int -> HotIdentity c -> ShowS)
-> (HotIdentity c -> String)
-> ([HotIdentity c] -> ShowS)
-> Show (HotIdentity c)
forall c. Int -> HotIdentity c -> ShowS
forall c. [HotIdentity c] -> ShowS
forall c. HotIdentity c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Int -> HotIdentity c -> ShowS
showsPrec :: Int -> HotIdentity c -> ShowS
$cshow :: forall c. HotIdentity c -> String
show :: HotIdentity c -> String
$cshowList :: forall c. [HotIdentity c] -> ShowS
showList :: [HotIdentity c] -> ShowS
Show, HotIdentity c -> HotIdentity c -> Bool
(HotIdentity c -> HotIdentity c -> Bool)
-> (HotIdentity c -> HotIdentity c -> Bool) -> Eq (HotIdentity c)
forall c. HotIdentity c -> HotIdentity c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. HotIdentity c -> HotIdentity c -> Bool
== :: HotIdentity c -> HotIdentity c -> Bool
$c/= :: forall c. HotIdentity c -> HotIdentity c -> Bool
/= :: HotIdentity c -> HotIdentity c -> Bool
Eq, Eq (HotIdentity c)
Eq (HotIdentity c) =>
(HotIdentity c -> HotIdentity c -> Ordering)
-> (HotIdentity c -> HotIdentity c -> Bool)
-> (HotIdentity c -> HotIdentity c -> Bool)
-> (HotIdentity c -> HotIdentity c -> Bool)
-> (HotIdentity c -> HotIdentity c -> Bool)
-> (HotIdentity c -> HotIdentity c -> HotIdentity c)
-> (HotIdentity c -> HotIdentity c -> HotIdentity c)
-> Ord (HotIdentity c)
HotIdentity c -> HotIdentity c -> Bool
HotIdentity c -> HotIdentity c -> Ordering
HotIdentity c -> HotIdentity c -> HotIdentity c
forall c. Eq (HotIdentity c)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall c. HotIdentity c -> HotIdentity c -> Bool
forall c. HotIdentity c -> HotIdentity c -> Ordering
forall c. HotIdentity c -> HotIdentity c -> HotIdentity c
$ccompare :: forall c. HotIdentity c -> HotIdentity c -> Ordering
compare :: HotIdentity c -> HotIdentity c -> Ordering
$c< :: forall c. HotIdentity c -> HotIdentity c -> Bool
< :: HotIdentity c -> HotIdentity c -> Bool
$c<= :: forall c. HotIdentity c -> HotIdentity c -> Bool
<= :: HotIdentity c -> HotIdentity c -> Bool
$c> :: forall c. HotIdentity c -> HotIdentity c -> Bool
> :: HotIdentity c -> HotIdentity c -> Bool
$c>= :: forall c. HotIdentity c -> HotIdentity c -> Bool
>= :: HotIdentity c -> HotIdentity c -> Bool
$cmax :: forall c. HotIdentity c -> HotIdentity c -> HotIdentity c
max :: HotIdentity c -> HotIdentity c -> HotIdentity c
$cmin :: forall c. HotIdentity c -> HotIdentity c -> HotIdentity c
min :: HotIdentity c -> HotIdentity c -> HotIdentity c
Ord, (forall x. HotIdentity c -> Rep (HotIdentity c) x)
-> (forall x. Rep (HotIdentity c) x -> HotIdentity c)
-> Generic (HotIdentity c)
forall x. Rep (HotIdentity c) x -> HotIdentity c
forall x. HotIdentity c -> Rep (HotIdentity c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (HotIdentity c) x -> HotIdentity c
forall c x. HotIdentity c -> Rep (HotIdentity c) x
$cfrom :: forall c x. HotIdentity c -> Rep (HotIdentity c) x
from :: forall x. HotIdentity c -> Rep (HotIdentity c) x
$cto :: forall c x. Rep (HotIdentity c) x -> HotIdentity c
to :: forall x. Rep (HotIdentity c) x -> HotIdentity c
Generic)
  deriving anyclass (Context -> HotIdentity c -> IO (Maybe ThunkInfo)
Proxy (HotIdentity c) -> String
(Context -> HotIdentity c -> IO (Maybe ThunkInfo))
-> (Context -> HotIdentity c -> IO (Maybe ThunkInfo))
-> (Proxy (HotIdentity c) -> String)
-> NoThunks (HotIdentity c)
forall c. Context -> HotIdentity c -> IO (Maybe ThunkInfo)
forall c. Proxy (HotIdentity c) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall c. Context -> HotIdentity c -> IO (Maybe ThunkInfo)
noThunks :: Context -> HotIdentity c -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall c. Context -> HotIdentity c -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> HotIdentity c -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall c. Proxy (HotIdentity c) -> String
showTypeOf :: Proxy (HotIdentity c) -> String
NoThunks)

data ShelleyTentativeHeaderState proto =
    ShelleyTentativeHeaderState
      -- | The block number of the last trap tentative header.
      !(WithOrigin BlockNo)
      -- | The set of all hot identies of those who issued trap tentative
      -- headers for the recorded block number.
      --
      -- Remember that 'TentativeHeaderState's are maintained in different
      -- contexts, and we might record different identities per block number in
      -- them:
      --
      --  - In ChainSel, we record all identities of trap headers we sent.
      --
      --  - In the BlockFetch punishment logic, for each upstream peer, we
      --    record the identities of trap headers they sent.
      !(Set (HotIdentity (ProtoCrypto proto)))
  deriving stock (Int -> ShelleyTentativeHeaderState proto -> ShowS
[ShelleyTentativeHeaderState proto] -> ShowS
ShelleyTentativeHeaderState proto -> String
(Int -> ShelleyTentativeHeaderState proto -> ShowS)
-> (ShelleyTentativeHeaderState proto -> String)
-> ([ShelleyTentativeHeaderState proto] -> ShowS)
-> Show (ShelleyTentativeHeaderState proto)
forall proto. Int -> ShelleyTentativeHeaderState proto -> ShowS
forall proto. [ShelleyTentativeHeaderState proto] -> ShowS
forall proto. ShelleyTentativeHeaderState proto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall proto. Int -> ShelleyTentativeHeaderState proto -> ShowS
showsPrec :: Int -> ShelleyTentativeHeaderState proto -> ShowS
$cshow :: forall proto. ShelleyTentativeHeaderState proto -> String
show :: ShelleyTentativeHeaderState proto -> String
$cshowList :: forall proto. [ShelleyTentativeHeaderState proto] -> ShowS
showList :: [ShelleyTentativeHeaderState proto] -> ShowS
Show, ShelleyTentativeHeaderState proto
-> ShelleyTentativeHeaderState proto -> Bool
(ShelleyTentativeHeaderState proto
 -> ShelleyTentativeHeaderState proto -> Bool)
-> (ShelleyTentativeHeaderState proto
    -> ShelleyTentativeHeaderState proto -> Bool)
-> Eq (ShelleyTentativeHeaderState proto)
forall proto.
ShelleyTentativeHeaderState proto
-> ShelleyTentativeHeaderState proto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall proto.
ShelleyTentativeHeaderState proto
-> ShelleyTentativeHeaderState proto -> Bool
== :: ShelleyTentativeHeaderState proto
-> ShelleyTentativeHeaderState proto -> Bool
$c/= :: forall proto.
ShelleyTentativeHeaderState proto
-> ShelleyTentativeHeaderState proto -> Bool
/= :: ShelleyTentativeHeaderState proto
-> ShelleyTentativeHeaderState proto -> Bool
Eq, (forall x.
 ShelleyTentativeHeaderState proto
 -> Rep (ShelleyTentativeHeaderState proto) x)
-> (forall x.
    Rep (ShelleyTentativeHeaderState proto) x
    -> ShelleyTentativeHeaderState proto)
-> Generic (ShelleyTentativeHeaderState proto)
forall x.
Rep (ShelleyTentativeHeaderState proto) x
-> ShelleyTentativeHeaderState proto
forall x.
ShelleyTentativeHeaderState proto
-> Rep (ShelleyTentativeHeaderState proto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto x.
Rep (ShelleyTentativeHeaderState proto) x
-> ShelleyTentativeHeaderState proto
forall proto x.
ShelleyTentativeHeaderState proto
-> Rep (ShelleyTentativeHeaderState proto) x
$cfrom :: forall proto x.
ShelleyTentativeHeaderState proto
-> Rep (ShelleyTentativeHeaderState proto) x
from :: forall x.
ShelleyTentativeHeaderState proto
-> Rep (ShelleyTentativeHeaderState proto) x
$cto :: forall proto x.
Rep (ShelleyTentativeHeaderState proto) x
-> ShelleyTentativeHeaderState proto
to :: forall x.
Rep (ShelleyTentativeHeaderState proto) x
-> ShelleyTentativeHeaderState proto
Generic)
  deriving anyclass (Context
-> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo)
Proxy (ShelleyTentativeHeaderState proto) -> String
(Context
 -> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo))
-> (Context
    -> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo))
-> (Proxy (ShelleyTentativeHeaderState proto) -> String)
-> NoThunks (ShelleyTentativeHeaderState proto)
forall proto.
Context
-> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo)
forall proto. Proxy (ShelleyTentativeHeaderState proto) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall proto.
Context
-> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo)
noThunks :: Context
-> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto.
Context
-> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> ShelleyTentativeHeaderState proto -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall proto. Proxy (ShelleyTentativeHeaderState proto) -> String
showTypeOf :: Proxy (ShelleyTentativeHeaderState proto) -> String
NoThunks)

data ShelleyTentativeHeaderView proto =
    ShelleyTentativeHeaderView BlockNo (HotIdentity (ProtoCrypto proto))

deriving stock instance ConsensusProtocol proto => Show (ShelleyTentativeHeaderView proto)
deriving stock instance ConsensusProtocol proto => Eq   (ShelleyTentativeHeaderView proto)

-- | A header can be pipelined iff no trap header with the same block number and
-- by the same issuer was pipelined before. See 'HotIdentity' for what exactly
-- we use for the issuer identity.
instance
  ( ShelleyCompatible proto era
  , BlockSupportsProtocol (ShelleyBlock proto era)
  ) => BlockSupportsDiffusionPipelining (ShelleyBlock proto era) where
  type TentativeHeaderState (ShelleyBlock proto era) =
    ShelleyTentativeHeaderState proto

  type TentativeHeaderView (ShelleyBlock proto era) =
    ShelleyTentativeHeaderView proto

  initialTentativeHeaderState :: Proxy (ShelleyBlock proto era)
-> TentativeHeaderState (ShelleyBlock proto era)
initialTentativeHeaderState Proxy (ShelleyBlock proto era)
_ =
      WithOrigin BlockNo
-> Set (HotIdentity (ProtoCrypto proto))
-> ShelleyTentativeHeaderState proto
forall proto.
WithOrigin BlockNo
-> Set (HotIdentity (ProtoCrypto proto))
-> ShelleyTentativeHeaderState proto
ShelleyTentativeHeaderState WithOrigin BlockNo
forall t. WithOrigin t
Origin Set (HotIdentity (ProtoCrypto proto))
forall a. Set a
Set.empty

  tentativeHeaderView :: BlockConfig (ShelleyBlock proto era)
-> Header (ShelleyBlock proto era)
-> TentativeHeaderView (ShelleyBlock proto era)
tentativeHeaderView BlockConfig (ShelleyBlock proto era)
_bcfg hdr :: Header (ShelleyBlock proto era)
hdr@(ShelleyHeader ShelleyProtocolHeader proto
sph ShelleyHash (ProtoCrypto proto)
_) =
      BlockNo
-> HotIdentity (ProtoCrypto proto)
-> ShelleyTentativeHeaderView proto
forall proto.
BlockNo
-> HotIdentity (ProtoCrypto proto)
-> ShelleyTentativeHeaderView proto
ShelleyTentativeHeaderView (Header (ShelleyBlock proto era) -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header (ShelleyBlock proto era)
hdr) HotIdentity {
          hiIssuer :: KeyHash 'BlockIssuer (ProtoCrypto proto)
hiIssuer  = VKey 'BlockIssuer (ProtoCrypto proto)
-> KeyHash 'BlockIssuer (ProtoCrypto proto)
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey (VKey 'BlockIssuer (ProtoCrypto proto)
 -> KeyHash 'BlockIssuer (ProtoCrypto proto))
-> VKey 'BlockIssuer (ProtoCrypto proto)
-> KeyHash 'BlockIssuer (ProtoCrypto proto)
forall a b. (a -> b) -> a -> b
$ ShelleyProtocolHeader proto
-> VKey 'BlockIssuer (ProtoCrypto proto)
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto
-> VKey 'BlockIssuer (ProtoCrypto proto)
pHeaderIssuer ShelleyProtocolHeader proto
sph
        , hiIssueNo :: Word64
hiIssueNo = ShelleyProtocolHeader proto -> Word64
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> Word64
pHeaderIssueNo ShelleyProtocolHeader proto
sph
        }

  applyTentativeHeaderView :: Proxy (ShelleyBlock proto era)
-> TentativeHeaderView (ShelleyBlock proto era)
-> TentativeHeaderState (ShelleyBlock proto era)
-> Maybe (TentativeHeaderState (ShelleyBlock proto era))
applyTentativeHeaderView Proxy (ShelleyBlock proto era)
_
    (ShelleyTentativeHeaderView BlockNo
bno HotIdentity (ProtoCrypto proto)
hdrIdentity)
    (ShelleyTentativeHeaderState WithOrigin BlockNo
lastBlockNo Set (HotIdentity (ProtoCrypto proto))
badIdentities)
    = case WithOrigin BlockNo -> WithOrigin BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
bno) WithOrigin BlockNo
lastBlockNo of
        Ordering
LT -> Maybe (TentativeHeaderState (ShelleyBlock proto era))
Maybe (ShelleyTentativeHeaderState proto)
forall a. Maybe a
Nothing
        Ordering
EQ -> do
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ HotIdentity (ProtoCrypto proto)
hdrIdentity HotIdentity (ProtoCrypto proto)
-> Set (HotIdentity (ProtoCrypto proto)) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (HotIdentity (ProtoCrypto proto))
badIdentities
          ShelleyTentativeHeaderState proto
-> Maybe (ShelleyTentativeHeaderState proto)
forall a. a -> Maybe a
Just (ShelleyTentativeHeaderState proto
 -> Maybe (ShelleyTentativeHeaderState proto))
-> ShelleyTentativeHeaderState proto
-> Maybe (ShelleyTentativeHeaderState proto)
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> Set (HotIdentity (ProtoCrypto proto))
-> ShelleyTentativeHeaderState proto
forall proto.
WithOrigin BlockNo
-> Set (HotIdentity (ProtoCrypto proto))
-> ShelleyTentativeHeaderState proto
ShelleyTentativeHeaderState
            WithOrigin BlockNo
lastBlockNo
            (HotIdentity (ProtoCrypto proto)
-> Set (HotIdentity (ProtoCrypto proto))
-> Set (HotIdentity (ProtoCrypto proto))
forall a. Ord a => a -> Set a -> Set a
Set.insert HotIdentity (ProtoCrypto proto)
hdrIdentity Set (HotIdentity (ProtoCrypto proto))
badIdentities)
        Ordering
GT ->
          TentativeHeaderState (ShelleyBlock proto era)
-> Maybe (TentativeHeaderState (ShelleyBlock proto era))
forall a. a -> Maybe a
Just (TentativeHeaderState (ShelleyBlock proto era)
 -> Maybe (TentativeHeaderState (ShelleyBlock proto era)))
-> TentativeHeaderState (ShelleyBlock proto era)
-> Maybe (TentativeHeaderState (ShelleyBlock proto era))
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> Set (HotIdentity (ProtoCrypto proto))
-> ShelleyTentativeHeaderState proto
forall proto.
WithOrigin BlockNo
-> Set (HotIdentity (ProtoCrypto proto))
-> ShelleyTentativeHeaderState proto
ShelleyTentativeHeaderState
            (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
bno)
            (HotIdentity (ProtoCrypto proto)
-> Set (HotIdentity (ProtoCrypto proto))
forall a. a -> Set a
Set.singleton HotIdentity (ProtoCrypto proto)
hdrIdentity)