{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.Node.RethrowPolicy (consensusRethrowPolicy) where
import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..))
import Data.Proxy (Proxy)
import Data.Typeable (Typeable)
import Ouroboros.Consensus.Block (StandardHash)
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
(BlockFetchServerException)
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
(ChainSyncClientException)
import Ouroboros.Consensus.Node.DbLock
import Ouroboros.Consensus.Node.DbMarker (DbMarkerError)
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDbError (..),
ChainDbFailure)
import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDBError)
import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB
import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError)
import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB
import Ouroboros.Consensus.Util.ResourceRegistry
(RegistryClosedException, ResourceRegistryThreadException,
TempRegistryException)
import Ouroboros.Network.RethrowPolicy
import System.FS.API.Types (FsError)
consensusRethrowPolicy ::
forall blk. (Typeable blk, StandardHash blk)
=> Proxy blk
-> RethrowPolicy
consensusRethrowPolicy :: forall blk.
(Typeable blk, StandardHash blk) =>
Proxy blk -> RethrowPolicy
consensusRethrowPolicy Proxy blk
pb =
(ErrorContext -> DbMarkerError -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (DbMarkerError
_ :: DbMarkerError) -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> DbMarkerError -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (DbMarkerError
_ :: DbMarkerError) -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> DbLocked -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (DbLocked
_ :: DbLocked) -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> ChainDbFailure blk -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (ChainDbFailure blk
_ :: ChainDbFailure blk) -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> VolatileDBError blk -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (VolatileDBError blk
e :: VolatileDBError blk) ->
case VolatileDBError blk
e of
VolatileDB.ApiMisuse{} -> ErrorCommand
ourBug
VolatileDB.UnexpectedFailure{} -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> ImmutableDBError blk -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (ImmutableDBError blk
e :: ImmutableDBError blk) ->
case ImmutableDBError blk
e of
ImmutableDB.ApiMisuse{} -> ErrorCommand
ourBug
ImmutableDB.UnexpectedFailure{} -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> FsError -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (FsError
_ :: FsError) -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> SystemClockMovedBackException -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (SystemClockMovedBackException
_ :: SystemClockMovedBackException) -> ErrorCommand
shutdownNode)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> ChainDbError blk -> ErrorCommand) -> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (ChainDbError blk
e :: ChainDbError blk) ->
case ChainDbError blk
e of
ClosedDBError{} -> ErrorCommand
shutdownNode
ClosedFollowerError{} -> ErrorCommand
ourBug
InvalidIteratorRange{} -> ErrorCommand
theyBuggyOrEvil)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> RegistryClosedException -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (RegistryClosedException
_ :: RegistryClosedException) -> ErrorCommand
ourBug)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> ResourceRegistryThreadException -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (ResourceRegistryThreadException
_ :: ResourceRegistryThreadException) -> ErrorCommand
ourBug)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> TempRegistryException -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (TempRegistryException
_ :: TempRegistryException) -> ErrorCommand
ourBug)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> BlockFetchServerException -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (BlockFetchServerException
_ :: BlockFetchServerException) -> ErrorCommand
distantPeer)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> ChainSyncClientException -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
_ctx (ChainSyncClientException
_ :: ChainSyncClientException) -> ErrorCommand
theyBuggyOrEvil)
RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> (ErrorContext -> ExceptionInLinkedThread -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy (\ErrorContext
ctx (ExceptionInLinkedThread String
_ SomeException
e) ->
RethrowPolicy -> RethrowPolicy_
runRethrowPolicy (Proxy blk -> RethrowPolicy
forall blk.
(Typeable blk, StandardHash blk) =>
Proxy blk -> RethrowPolicy
consensusRethrowPolicy Proxy blk
pb) ErrorContext
ctx SomeException
e)
where
shutdownNode :: ErrorCommand
shutdownNode :: ErrorCommand
shutdownNode = ErrorCommand
ShutdownNode
distantPeer :: ErrorCommand
distantPeer :: ErrorCommand
distantPeer = ErrorCommand
ShutdownPeer
theyBuggyOrEvil :: ErrorCommand
theyBuggyOrEvil :: ErrorCommand
theyBuggyOrEvil = ErrorCommand
ShutdownPeer
ourBug :: ErrorCommand
ourBug :: ErrorCommand
ourBug = ErrorCommand
ShutdownPeer