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

-- | Rethrow policy for 'MuxConnectionHandler'.
--
-- Connection manager has a centralised way of handling exceptions.
-- 'RethrowPolicy' is a way to decided wheather 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 (MuxError)
import           Network.Mux.Types (MuxRuntimeError (..))


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
showList :: [ErrorCommand] -> ShowS
$cshowList :: [ErrorCommand] -> ShowS
show :: ErrorCommand -> String
$cshow :: ErrorCommand -> String
showsPrec :: Int -> ErrorCommand -> ShowS
$cshowsPrec :: Int -> 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


-- | Weather an exception happend on outbound or inbound connection.
--
-- TODO: It would be more useful to have access weather the exception happend
-- 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
showList :: [ErrorContext] -> ShowS
$cshowList :: [ErrorContext] -> ShowS
show :: ErrorContext -> String
$cshow :: ErrorContext -> String
showsPrec :: Int -> ErrorContext -> ShowS
$cshowsPrec :: Int -> ErrorContext -> ShowS
Show


type RethrowPolicy_ = ErrorContext -> SomeException -> ErrorCommand

newtype RethrowPolicy = RethrowPolicy {
    RethrowPolicy -> RethrowPolicy_
runRethrowPolicy :: RethrowPolicy_
  }
  deriving b -> RethrowPolicy -> RethrowPolicy
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
stimes :: b -> RethrowPolicy -> RethrowPolicy
$cstimes :: forall b. Integral b => b -> RethrowPolicy -> RethrowPolicy
sconcat :: NonEmpty RethrowPolicy -> RethrowPolicy
$csconcat :: NonEmpty RethrowPolicy -> RethrowPolicy
<> :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
$c<> :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
Semigroup via RethrowPolicy_
  deriving 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
mconcat :: [RethrowPolicy] -> RethrowPolicy
$cmconcat :: [RethrowPolicy] -> RethrowPolicy
mappend :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
$cmappend :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
mempty :: RethrowPolicy
$cmempty :: RethrowPolicy
$cp1Monoid :: Semigroup RethrowPolicy
Monoid    via RethrowPolicy_


-- | Smart constructor for 'RethrowPolicy'.
--
mkRethrowPolicy :: forall e.
                   Exception e
                => (ErrorContext -> e -> ErrorCommand)
                -> RethrowPolicy
mkRethrowPolicy :: (ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy ErrorContext -> e -> ErrorCommand
fn =
    RethrowPolicy_ -> RethrowPolicy
RethrowPolicy (RethrowPolicy_ -> RethrowPolicy)
-> RethrowPolicy_ -> 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 -> MuxError -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy ( \ErrorContext
_ (MuxError
_ :: MuxError) -> ErrorCommand
ShutdownPeer )
                     RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> MuxRuntimeError -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy ( \ErrorContext
_ (MuxRuntimeError
e :: MuxRuntimeError) ->
                                          case MuxRuntimeError
e of
                                            ProtocolAlreadyRunning       {} -> ErrorCommand
ShutdownPeer
                                            UnknownProtocolInternalError {} -> ErrorCommand
ShutdownNode
                                            MuxBlockedOnCompletionVar    {} -> 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