{-# 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