{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | How to punish the sender of a invalid block
module Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment
  ( -- * opaque
    InvalidBlockPunishment
  , enact

    -- * combinators
  , Invalidity (..)
  , branch
  , mkForDiffusionPipelining
  , mkPunishThisThread
  , noPunishment
  ) where

import qualified Control.Exception as Exn
import Control.Monad (join)
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Util.IOLike

-- | Is the added block itself invalid, or is its prefix invalid?
data Invalidity
  = BlockItself
  | BlockPrefix

-- | How to handle a discovered 'Invalidity'
--
-- This type is opaque because the soundness of the punishment is subtle because
-- of where it is invoked during the chain selection. As a result, arbitrary
-- monadic actions would be foot guns. Instead, this module defines a small DSL
-- for punishment that we judge to be sound.
newtype InvalidBlockPunishment m = InvalidBlockPunishment
  { forall (m :: * -> *).
InvalidBlockPunishment m -> Invalidity -> m ()
enact :: Invalidity -> m ()
  }
  deriving
    Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo)
Proxy (InvalidBlockPunishment m) -> String
(Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo))
-> (Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo))
-> (Proxy (InvalidBlockPunishment m) -> String)
-> NoThunks (InvalidBlockPunishment m)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *).
Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo)
forall (m :: * -> *). Proxy (InvalidBlockPunishment m) -> String
$cnoThunks :: forall (m :: * -> *).
Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo)
noThunks :: Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *).
Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> InvalidBlockPunishment m -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *). Proxy (InvalidBlockPunishment m) -> String
showTypeOf :: Proxy (InvalidBlockPunishment m) -> String
NoThunks
    via OnlyCheckWhnfNamed "InvalidBlockPunishment" (InvalidBlockPunishment m)

-- | A noop punishment
noPunishment :: Applicative m => InvalidBlockPunishment m
noPunishment :: forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
noPunishment = (Invalidity -> m ()) -> InvalidBlockPunishment m
forall (m :: * -> *).
(Invalidity -> m ()) -> InvalidBlockPunishment m
InvalidBlockPunishment ((Invalidity -> m ()) -> InvalidBlockPunishment m)
-> (Invalidity -> m ()) -> InvalidBlockPunishment m
forall a b. (a -> b) -> a -> b
$ \Invalidity
_invalidity -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Create a punishment that kills this thread
mkPunishThisThread :: IOLike m => m (InvalidBlockPunishment m)
mkPunishThisThread :: forall (m :: * -> *). IOLike m => m (InvalidBlockPunishment m)
mkPunishThisThread = do
  tid <- m (ThreadId m)
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
  pure $ InvalidBlockPunishment $ \Invalidity
_invalidity ->
    ThreadId m -> PeerSentAnInvalidBlockException -> m ()
forall e. Exception e => ThreadId m -> e -> m ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId m
tid PeerSentAnInvalidBlockException
PeerSentAnInvalidBlockException

-- | Thrown asynchronously to the client thread that added the block whose
-- processing involved an invalid block.
--
-- See 'punishThisThread'.
data PeerSentAnInvalidBlockException = PeerSentAnInvalidBlockException
  deriving Int -> PeerSentAnInvalidBlockException -> ShowS
[PeerSentAnInvalidBlockException] -> ShowS
PeerSentAnInvalidBlockException -> String
(Int -> PeerSentAnInvalidBlockException -> ShowS)
-> (PeerSentAnInvalidBlockException -> String)
-> ([PeerSentAnInvalidBlockException] -> ShowS)
-> Show PeerSentAnInvalidBlockException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerSentAnInvalidBlockException -> ShowS
showsPrec :: Int -> PeerSentAnInvalidBlockException -> ShowS
$cshow :: PeerSentAnInvalidBlockException -> String
show :: PeerSentAnInvalidBlockException -> String
$cshowList :: [PeerSentAnInvalidBlockException] -> ShowS
showList :: [PeerSentAnInvalidBlockException] -> ShowS
Show

instance Exn.Exception PeerSentAnInvalidBlockException

-- | Allocate a stateful punishment that performs the given punishment if the
-- given header does not satisfy the diffusion pipelining criterion.
mkForDiffusionPipelining ::
  forall m blk.
  ( IOLike m
  , BlockSupportsDiffusionPipelining blk
  ) =>
  STM
    m
    ( BlockConfig blk ->
      Header blk ->
      InvalidBlockPunishment m ->
      InvalidBlockPunishment m
    )
mkForDiffusionPipelining :: forall (m :: * -> *) blk.
(IOLike m, BlockSupportsDiffusionPipelining blk) =>
STM
  m
  (BlockConfig blk
   -> Header blk
   -> InvalidBlockPunishment m
   -> InvalidBlockPunishment m)
mkForDiffusionPipelining = do
  var <- TentativeHeaderState blk
-> STM m (StrictTVar m (TentativeHeaderState blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> STM m (StrictTVar m a)
newTVar (Proxy blk -> TentativeHeaderState blk
forall blk.
BlockSupportsDiffusionPipelining blk =>
Proxy blk -> TentativeHeaderState blk
initialTentativeHeaderState (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk))
  pure $ \BlockConfig blk
cfg Header blk
new InvalidBlockPunishment m
punish -> (Invalidity -> m ()) -> InvalidBlockPunishment m
forall (m :: * -> *).
(Invalidity -> m ()) -> InvalidBlockPunishment m
InvalidBlockPunishment ((Invalidity -> m ()) -> InvalidBlockPunishment m)
-> (Invalidity -> m ()) -> InvalidBlockPunishment m
forall a b. (a -> b) -> a -> b
$ \Invalidity
invalidity -> m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ do
    mbSt' <- BlockConfig blk
-> Header blk
-> TentativeHeaderState blk
-> Maybe (TentativeHeaderState blk)
forall blk.
BlockSupportsDiffusionPipelining blk =>
BlockConfig blk
-> Header blk
-> TentativeHeaderState blk
-> Maybe (TentativeHeaderState blk)
updateTentativeHeaderState BlockConfig blk
cfg Header blk
new (TentativeHeaderState blk -> Maybe (TentativeHeaderState blk))
-> STM m (TentativeHeaderState blk)
-> STM m (Maybe (TentativeHeaderState blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (TentativeHeaderState blk)
-> STM m (TentativeHeaderState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (TentativeHeaderState blk)
var
    case mbSt' of
      Just TentativeHeaderState blk
st' -> do
        StrictTVar m (TentativeHeaderState blk)
-> TentativeHeaderState blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (TentativeHeaderState blk)
var TentativeHeaderState blk
st'
        m () -> STM m (m ())
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM m (m ())) -> m () -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe (TentativeHeaderState blk)
Nothing ->
        m () -> STM m (m ())
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM m (m ())) -> m () -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ InvalidBlockPunishment m -> Invalidity -> m ()
forall (m :: * -> *).
InvalidBlockPunishment m -> Invalidity -> m ()
enact InvalidBlockPunishment m
punish Invalidity
invalidity

-- | Punish according to the 'Invalidity'
branch :: (Invalidity -> InvalidBlockPunishment m) -> InvalidBlockPunishment m
branch :: forall (m :: * -> *).
(Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
branch Invalidity -> InvalidBlockPunishment m
f = (Invalidity -> m ()) -> InvalidBlockPunishment m
forall (m :: * -> *).
(Invalidity -> m ()) -> InvalidBlockPunishment m
InvalidBlockPunishment ((Invalidity -> m ()) -> InvalidBlockPunishment m)
-> (Invalidity -> m ()) -> InvalidBlockPunishment m
forall a b. (a -> b) -> a -> b
$ \Invalidity
invalidity ->
  InvalidBlockPunishment m -> Invalidity -> m ()
forall (m :: * -> *).
InvalidBlockPunishment m -> Invalidity -> m ()
enact (Invalidity -> InvalidBlockPunishment m
f Invalidity
invalidity) Invalidity
invalidity