{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Network.RethrowPolicy
( RethrowPolicy (..)
, mkRethrowPolicy
, ErrorCommand (..)
, ErrorContext (..)
, muxErrorRethrowPolicy
, ioErrorRethrowPolicy
) where
import Control.Exception
import Network.Mux.Trace (MuxError)
import Network.Mux.Types (MuxRuntimeError (..))
data ErrorCommand =
ShutdownNode
| 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
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
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
type RethrowPolicy_ = ErrorContext -> SomeException -> ErrorCommand
newtype RethrowPolicy = RethrowPolicy {
RethrowPolicy -> RethrowPolicy_
runRethrowPolicy :: RethrowPolicy_
}
deriving 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 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
$cmempty :: RethrowPolicy
mempty :: RethrowPolicy
$cmappend :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
mappend :: RethrowPolicy -> RethrowPolicy -> RethrowPolicy
$cmconcat :: [RethrowPolicy] -> RethrowPolicy
mconcat :: [RethrowPolicy] -> RethrowPolicy
Monoid via RethrowPolicy_
mkRethrowPolicy :: forall e.
Exception e
=> (ErrorContext -> e -> ErrorCommand)
-> RethrowPolicy
mkRethrowPolicy :: forall e.
Exception e =>
(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
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