{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}

-- | Rethrow policy for 'MuxConnectionHandler'.
--
-- Connection manager has a centralised way of handling exceptions.
-- 'RethrowPolicy' is a way to decided whether it is enough to shutdown
-- connection or the node should shut down itself.  Theis mechanism is affected
-- by the design choices in the mutliplexer.
--
-- Whenever a mini-protocol throws an exception, the bearer is closed.  There is
-- no way to recover a bidirectional connection if one side failed, in such way
-- that the other end could still re-use it, e.g.  if the initiator throws, we
-- cannot just restart it on the same bearer, since there might be unconsumed
-- bytes on the other end.
--
-- 'RethrowPolicy' is supplied to 'makeMuxConnectionHandler' which creates both
-- the action that runs on each connection and error handler.  Error handler is
-- attached by the connection manager (see
-- 'Ouroboros.Network.ConnectionManager.Core').  This error handler is using
-- 'RethrowPolicy'.
--
-- This mechanism is enough for both:
--
--  * the server implemented in `Ouroboros.Network.ConnectionManager.Server',
--  * 'PeerStateActions' used by peer-to-peer governor.
--
-- Since both start mini-protocols with 'runMiniProtocol' they can also have
-- access to the result / exception thrown of a mini-protocol.
-- 'PeerStateActions' are only using this to inform the governor that the
-- peer transitioned to 'PeerCold' or to deactivate the peer.
--
module Ouroboros.Network.RethrowPolicy
  ( RethrowPolicy (..)
  , mkRethrowPolicy
  , ErrorCommand (..)
  , ErrorContext (..)
    -- * Example policies
  , muxErrorRethrowPolicy
  , ioErrorRethrowPolicy
  ) where

import Control.Exception

import Network.Mux.Trace qualified as Mx
import Network.Mux.Types qualified as Mx


data ErrorCommand =
    -- | Shutdown node.
    ShutdownNode

    -- | Shutdown connection with the peer.
    --
  | ShutdownPeer
  deriving Int -> ErrorCommand -> ShowS
[ErrorCommand] -> ShowS
ErrorCommand -> String
(Int -> ErrorCommand -> ShowS)
-> (ErrorCommand -> String)
-> ([ErrorCommand] -> ShowS)
-> Show ErrorCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorCommand -> ShowS
showsPrec :: Int -> ErrorCommand -> ShowS
$cshow :: ErrorCommand -> String
show :: ErrorCommand -> String
$cshowList :: [ErrorCommand] -> ShowS
showList :: [ErrorCommand] -> ShowS
Show

-- | 'ErrorCommand' is a commutative semigroup with 'ShutdownNode' being an
-- absorbing element, and 'ShutdownPeer' is the unit element.
--
instance Semigroup ErrorCommand where
    ErrorCommand
ShutdownNode <> :: ErrorCommand -> ErrorCommand -> ErrorCommand
<> ErrorCommand
_            = ErrorCommand
ShutdownNode
    ErrorCommand
_ <> ErrorCommand
ShutdownNode            = ErrorCommand
ShutdownNode
    ErrorCommand
ShutdownPeer <> ErrorCommand
ShutdownPeer = ErrorCommand
ShutdownPeer

instance Monoid ErrorCommand where
    mempty :: ErrorCommand
mempty = ErrorCommand
ShutdownPeer


-- | Whether an exception happened on outbound or inbound connection.
--
-- TODO: It would be more useful to have access to whether the exception
-- happened on initiator or responder. The easiest way to fix this is make mux
-- throw the exception together with context.  This allows to keep error
-- handling be done only by the connection manager (rather than by server and
-- 'PeerStateActions').
--
data ErrorContext = OutboundError
                  | InboundError
    deriving Int -> ErrorContext -> ShowS
[ErrorContext] -> ShowS
ErrorContext -> String
(Int -> ErrorContext -> ShowS)
-> (ErrorContext -> String)
-> ([ErrorContext] -> ShowS)
-> Show ErrorContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorContext -> ShowS
showsPrec :: Int -> ErrorContext -> ShowS
$cshow :: ErrorContext -> String
show :: ErrorContext -> String
$cshowList :: [ErrorContext] -> ShowS
showList :: [ErrorContext] -> ShowS
Show


newtype RethrowPolicy = RethrowPolicy {
    RethrowPolicy -> ErrorContext -> SomeException -> ErrorCommand
runRethrowPolicy :: ErrorContext -> SomeException -> ErrorCommand
  }
  deriving newtype NonEmpty RethrowPolicy -> RethrowPolicy
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
(RethrowPolicy -> RethrowPolicy -> RethrowPolicy)
-> (NonEmpty RethrowPolicy -> RethrowPolicy)
-> (forall b. Integral b => b -> RethrowPolicy -> RethrowPolicy)
-> Semigroup RethrowPolicy
forall b. Integral b => b -> RethrowPolicy -> RethrowPolicy
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
<> :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
$csconcat :: NonEmpty RethrowPolicy -> RethrowPolicy
sconcat :: NonEmpty RethrowPolicy -> RethrowPolicy
$cstimes :: forall b. Integral b => b -> RethrowPolicy -> RethrowPolicy
stimes :: forall b. Integral b => b -> RethrowPolicy -> RethrowPolicy
Semigroup
  deriving newtype Semigroup RethrowPolicy
RethrowPolicy
Semigroup RethrowPolicy =>
RethrowPolicy
-> (RethrowPolicy -> RethrowPolicy -> RethrowPolicy)
-> ([RethrowPolicy] -> RethrowPolicy)
-> Monoid RethrowPolicy
[RethrowPolicy] -> RethrowPolicy
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: RethrowPolicy
mempty :: RethrowPolicy
$cmappend :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
mappend :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
$cmconcat :: [RethrowPolicy] -> RethrowPolicy
mconcat :: [RethrowPolicy] -> RethrowPolicy
Monoid


-- | Smart constructor for 'RethrowPolicy'.
--
mkRethrowPolicy :: forall e.
                   Exception e
                => (ErrorContext -> e -> ErrorCommand)
                -> RethrowPolicy
mkRethrowPolicy :: forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy ErrorContext -> e -> ErrorCommand
fn =
    (ErrorContext -> SomeException -> ErrorCommand) -> RethrowPolicy
RethrowPolicy ((ErrorContext -> SomeException -> ErrorCommand) -> RethrowPolicy)
-> (ErrorContext -> SomeException -> ErrorCommand) -> RethrowPolicy
forall a b. (a -> b) -> a -> b
$ \ErrorContext
ctx SomeException
err ->
      case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
        Just e
e  -> ErrorContext -> e -> ErrorCommand
fn ErrorContext
ctx e
e
        Maybe e
Nothing -> ErrorCommand
ShutdownPeer

--
-- Some example error policies
--

muxErrorRethrowPolicy, ioErrorRethrowPolicy :: RethrowPolicy

muxErrorRethrowPolicy :: RethrowPolicy
muxErrorRethrowPolicy = (ErrorContext -> Error -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy ( \ErrorContext
_ (Error
_ :: Mx.Error) -> ErrorCommand
ShutdownPeer )
                     RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> RuntimeError -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy ( \ErrorContext
_ (RuntimeError
e :: Mx.RuntimeError) ->
                                          case RuntimeError
e of
                                            Mx.ProtocolAlreadyRunning       {} -> ErrorCommand
ShutdownPeer
                                            Mx.UnknownProtocolInternalError {} -> ErrorCommand
ShutdownNode
                                            Mx.BlockedOnCompletionVar       {} -> ErrorCommand
ShutdownPeer
                                        )

ioErrorRethrowPolicy :: RethrowPolicy
ioErrorRethrowPolicy  = (ErrorContext -> IOError -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy ((ErrorContext -> IOError -> ErrorCommand) -> RethrowPolicy)
-> (ErrorContext -> IOError -> ErrorCommand) -> RethrowPolicy
forall a b. (a -> b) -> a -> b
$ \ErrorContext
_ (IOError
_ :: IOError)  -> ErrorCommand
ShutdownPeer