{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Error policies, and integration with 'SuspendDecision'-semigroup action on
-- 'PeerState'.
--
module Ouroboros.Network.ErrorPolicy
  ( ErrorPolicies (..)
  , nullErrorPolicies
  , ErrorPolicy (..)
  , evalErrorPolicy
  , evalErrorPolicies
  , CompleteApplication
  , CompleteApplicationResult (..)
  , Result (..)
  , completeApplicationTx
    -- * Traces
  , ErrorPolicyTrace (..)
  , traceErrorPolicy
  , WithAddr (..)
    -- * Re-exports of PeerState
  , PeerStates
  , SuspendDecision (..)
  ) where

import Control.Exception (Exception, IOException, SomeException (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe)
import Data.Semigroup (sconcat)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Typeable (Proxy (..), cast, tyConName, typeRep, typeRepTyCon)
import Text.Printf

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI

import Ouroboros.Network.Subscription.PeerState

data ErrorPolicy where
     ErrorPolicy :: forall e.
                      Exception e
                   => (e -> Maybe (SuspendDecision DiffTime))
                   -- ^ @Nothing@ means no decision. It is equivalent to not
                   -- having the policy at all. In 'evalErrorPolicies' this will
                   -- fall-through and match against the remaining policies.
                   -> ErrorPolicy

instance Show ErrorPolicy where
    show :: ErrorPolicy -> String
show (ErrorPolicy (e -> Maybe (SuspendDecision DiffTime)
_err :: e -> Maybe (SuspendDecision DiffTime))) =
           String
"ErrorPolicy ("
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ TyCon -> String
tyConName (TypeRep -> TyCon
typeRepTyCon (Proxy e -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy e
forall {k} (t :: k). Proxy t
Proxy :: Proxy e)))
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"


evalErrorPolicy :: forall e.
                   Exception e
                => e
                -> ErrorPolicy
                -> Maybe (SuspendDecision DiffTime)
evalErrorPolicy :: forall e.
Exception e =>
e -> ErrorPolicy -> Maybe (SuspendDecision DiffTime)
evalErrorPolicy e
e ErrorPolicy
p =
    case ErrorPolicy
p of
      ErrorPolicy (e -> Maybe (SuspendDecision DiffTime)
f :: e' -> Maybe (SuspendDecision DiffTime))
        -> case e -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e :: Maybe e' of
              Maybe e
Nothing -> Maybe (SuspendDecision DiffTime)
forall a. Maybe a
Nothing
              Just e
e' -> e -> Maybe (SuspendDecision DiffTime)
f e
e'

-- | Evaluate a list of 'ErrorPolicy's; If none of them applies this function
-- returns 'Nothing', in this case the exception will be traced and not thrown.
--
evalErrorPolicies :: forall e.
                     Exception e
                  => e
                  -> [ErrorPolicy]
                  -> Maybe (SuspendDecision DiffTime)
evalErrorPolicies :: forall e.
Exception e =>
e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
evalErrorPolicies e
e =
    [SuspendDecision DiffTime] -> Maybe (SuspendDecision DiffTime)
f ([SuspendDecision DiffTime] -> Maybe (SuspendDecision DiffTime))
-> ([ErrorPolicy] -> [SuspendDecision DiffTime])
-> [ErrorPolicy]
-> Maybe (SuspendDecision DiffTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ErrorPolicy -> Maybe (SuspendDecision DiffTime))
-> [ErrorPolicy] -> [SuspendDecision DiffTime]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (e -> ErrorPolicy -> Maybe (SuspendDecision DiffTime)
forall e.
Exception e =>
e -> ErrorPolicy -> Maybe (SuspendDecision DiffTime)
evalErrorPolicy e
e)
  where
    f :: [SuspendDecision DiffTime]
      -> Maybe (SuspendDecision DiffTime)
    f :: [SuspendDecision DiffTime] -> Maybe (SuspendDecision DiffTime)
f []          = Maybe (SuspendDecision DiffTime)
forall a. Maybe a
Nothing
    f (SuspendDecision DiffTime
cmd : [SuspendDecision DiffTime]
rst) = SuspendDecision DiffTime -> Maybe (SuspendDecision DiffTime)
forall a. a -> Maybe a
Just (SuspendDecision DiffTime -> Maybe (SuspendDecision DiffTime))
-> SuspendDecision DiffTime -> Maybe (SuspendDecision DiffTime)
forall a b. (a -> b) -> a -> b
$ NonEmpty (SuspendDecision DiffTime) -> SuspendDecision DiffTime
forall a. Semigroup a => NonEmpty a -> a
sconcat (SuspendDecision DiffTime
cmd SuspendDecision DiffTime
-> [SuspendDecision DiffTime]
-> NonEmpty (SuspendDecision DiffTime)
forall a. a -> [a] -> NonEmpty a
:| [SuspendDecision DiffTime]
rst)


-- | List of error policies for exception handling and a policy for handing
-- application return values.
--
data ErrorPolicies = ErrorPolicies {
    -- | Application Error Policies
    ErrorPolicies -> [ErrorPolicy]
epAppErrorPolicies :: [ErrorPolicy]
    -- | `connect` Error Policies
  , ErrorPolicies -> [ErrorPolicy]
epConErrorPolicies :: [ErrorPolicy]
  }

nullErrorPolicies :: ErrorPolicies
nullErrorPolicies :: ErrorPolicies
nullErrorPolicies = [ErrorPolicy] -> [ErrorPolicy] -> ErrorPolicies
ErrorPolicies [] []

instance Semigroup ErrorPolicies where
    ErrorPolicies [ErrorPolicy]
aep [ErrorPolicy]
cep <> :: ErrorPolicies -> ErrorPolicies -> ErrorPolicies
<> ErrorPolicies [ErrorPolicy]
aep' [ErrorPolicy]
cep'
      = [ErrorPolicy] -> [ErrorPolicy] -> ErrorPolicies
ErrorPolicies ([ErrorPolicy]
aep [ErrorPolicy] -> [ErrorPolicy] -> [ErrorPolicy]
forall a. Semigroup a => a -> a -> a
<> [ErrorPolicy]
aep') ([ErrorPolicy]
cep [ErrorPolicy] -> [ErrorPolicy] -> [ErrorPolicy]
forall a. Semigroup a => a -> a -> a
<> [ErrorPolicy]
cep')

-- | Sum type which distinguishes between connection and application
-- exception traces.
--
data ConnectionOrApplicationExceptionTrace err =
     -- | Trace of exception thrown by `connect`
     ConnectionExceptionTrace err
     -- | Trace of exception thrown by an application
   | ApplicationExceptionTrace err
   deriving (Int -> ConnectionOrApplicationExceptionTrace err -> ShowS
[ConnectionOrApplicationExceptionTrace err] -> ShowS
ConnectionOrApplicationExceptionTrace err -> String
(Int -> ConnectionOrApplicationExceptionTrace err -> ShowS)
-> (ConnectionOrApplicationExceptionTrace err -> String)
-> ([ConnectionOrApplicationExceptionTrace err] -> ShowS)
-> Show (ConnectionOrApplicationExceptionTrace err)
forall err.
Show err =>
Int -> ConnectionOrApplicationExceptionTrace err -> ShowS
forall err.
Show err =>
[ConnectionOrApplicationExceptionTrace err] -> ShowS
forall err.
Show err =>
ConnectionOrApplicationExceptionTrace err -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall err.
Show err =>
Int -> ConnectionOrApplicationExceptionTrace err -> ShowS
showsPrec :: Int -> ConnectionOrApplicationExceptionTrace err -> ShowS
$cshow :: forall err.
Show err =>
ConnectionOrApplicationExceptionTrace err -> String
show :: ConnectionOrApplicationExceptionTrace err -> String
$cshowList :: forall err.
Show err =>
[ConnectionOrApplicationExceptionTrace err] -> ShowS
showList :: [ConnectionOrApplicationExceptionTrace err] -> ShowS
Show, (forall a b.
 (a -> b)
 -> ConnectionOrApplicationExceptionTrace a
 -> ConnectionOrApplicationExceptionTrace b)
-> (forall a b.
    a
    -> ConnectionOrApplicationExceptionTrace b
    -> ConnectionOrApplicationExceptionTrace a)
-> Functor ConnectionOrApplicationExceptionTrace
forall a b.
a
-> ConnectionOrApplicationExceptionTrace b
-> ConnectionOrApplicationExceptionTrace a
forall a b.
(a -> b)
-> ConnectionOrApplicationExceptionTrace a
-> ConnectionOrApplicationExceptionTrace b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b.
(a -> b)
-> ConnectionOrApplicationExceptionTrace a
-> ConnectionOrApplicationExceptionTrace b
fmap :: forall a b.
(a -> b)
-> ConnectionOrApplicationExceptionTrace a
-> ConnectionOrApplicationExceptionTrace b
$c<$ :: forall a b.
a
-> ConnectionOrApplicationExceptionTrace b
-> ConnectionOrApplicationExceptionTrace a
<$ :: forall a b.
a
-> ConnectionOrApplicationExceptionTrace b
-> ConnectionOrApplicationExceptionTrace a
Functor)


-- | Complete a connection, which receive application result (or exception).
--
type CompleteApplication m s addr r =
    Result addr r -> s -> STM m (CompleteApplicationResult m addr s)


-- | Result of the connection thread.  It's either result of an application, or
-- an exception thrown by it.
--
data Result addr r where
     ApplicationResult
       :: !Time
       -> !addr
       -> !r
       -> Result addr r

     Connected
       :: !Time
       -> !addr
       -> Result addr r

     ConnectionError
       :: Exception e
       => !Time
       -> !addr
       -> !e
       -> Result addr r

     ApplicationError
       :: Exception e
       => !Time
       -> !addr
       -> !e
       -> Result addr r


data CompleteApplicationResult m addr s =
    CompleteApplicationResult {
        forall (m :: * -> *) addr s.
CompleteApplicationResult m addr s -> s
carState   :: !s,
        -- ^ new state
        forall (m :: * -> *) addr s.
CompleteApplicationResult m addr s -> Set (Async m ())
carThreads :: Set (Async m ()),
        -- ^ threads to kill
        forall (m :: * -> *) addr s.
CompleteApplicationResult m addr s
-> Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   :: Maybe (WithAddr addr ErrorPolicyTrace)
        -- ^ trace points
      }
  deriving (forall a b.
 (a -> b)
 -> CompleteApplicationResult m addr a
 -> CompleteApplicationResult m addr b)
-> (forall a b.
    a
    -> CompleteApplicationResult m addr b
    -> CompleteApplicationResult m addr a)
-> Functor (CompleteApplicationResult m addr)
forall a b.
a
-> CompleteApplicationResult m addr b
-> CompleteApplicationResult m addr a
forall a b.
(a -> b)
-> CompleteApplicationResult m addr a
-> CompleteApplicationResult m addr b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) addr a b.
a
-> CompleteApplicationResult m addr b
-> CompleteApplicationResult m addr a
forall (m :: * -> *) addr a b.
(a -> b)
-> CompleteApplicationResult m addr a
-> CompleteApplicationResult m addr b
$cfmap :: forall (m :: * -> *) addr a b.
(a -> b)
-> CompleteApplicationResult m addr a
-> CompleteApplicationResult m addr b
fmap :: forall a b.
(a -> b)
-> CompleteApplicationResult m addr a
-> CompleteApplicationResult m addr b
$c<$ :: forall (m :: * -> *) addr a b.
a
-> CompleteApplicationResult m addr b
-> CompleteApplicationResult m addr a
<$ :: forall a b.
a
-> CompleteApplicationResult m addr b
-> CompleteApplicationResult m addr a
Functor


-- | 'CompleteApplication' callback
--
completeApplicationTx
  :: forall m addr a.
     ( MonadAsync  m
     , Ord addr
     , Ord (Async m ())
     )
  => ErrorPolicies
  -> CompleteApplication m
       (PeerStates m addr)
       addr
       a

-- the 'ResultQ' did not throw the exception yet; it should not happen.
completeApplicationTx :: forall (m :: * -> *) addr a.
(MonadAsync m, Ord addr, Ord (Async m ())) =>
ErrorPolicies -> CompleteApplication m (PeerStates m addr) addr a
completeApplicationTx ErrorPolicies
_ Result addr a
_ ps :: PeerStates m addr
ps@ThrowException{} = CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompleteApplicationResult m addr (PeerStates m addr)
 -> STM m (CompleteApplicationResult m addr (PeerStates m addr)))
-> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a b. (a -> b) -> a -> b
$
    CompleteApplicationResult {
        carState :: PeerStates m addr
carState   = PeerStates m addr
ps,
        carThreads :: Set (Async m ())
carThreads = Set (Async m ())
forall a. Set a
Set.empty,
        carTrace :: Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   = Maybe (WithAddr addr ErrorPolicyTrace)
forall a. Maybe a
Nothing
      }

-- application returned; classify the return value and update the state.
completeApplicationTx ErrorPolicies
_ ApplicationResult{} PeerStates m addr
ps =
    CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompleteApplicationResult m addr (PeerStates m addr)
 -> STM m (CompleteApplicationResult m addr (PeerStates m addr)))
-> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a b. (a -> b) -> a -> b
$ CompleteApplicationResult {
        carState :: PeerStates m addr
carState   = PeerStates m addr
ps,
        carThreads :: Set (Async m ())
carThreads = Set (Async m ())
forall a. Set a
Set.empty,
        carTrace :: Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   = Maybe (WithAddr addr ErrorPolicyTrace)
forall a. Maybe a
Nothing
      }

-- application errored
completeApplicationTx ErrorPolicies {[ErrorPolicy]
epAppErrorPolicies :: ErrorPolicies -> [ErrorPolicy]
epAppErrorPolicies :: [ErrorPolicy]
epAppErrorPolicies} (ApplicationError Time
t addr
addr e
e) PeerStates m addr
ps =
  case e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
forall e.
Exception e =>
e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
evalErrorPolicies e
e [ErrorPolicy]
epAppErrorPolicies of
    -- the error is not handled by any policy; we're not rethrowing the
    -- error from the main thread, we only trace it.  This will only kill
    -- the local consumer application.
    Maybe (SuspendDecision DiffTime)
Nothing  -> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompleteApplicationResult m addr (PeerStates m addr)
 -> STM m (CompleteApplicationResult m addr (PeerStates m addr)))
-> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a b. (a -> b) -> a -> b
$
      CompleteApplicationResult {
          carState :: PeerStates m addr
carState   = PeerStates m addr
ps,
          carThreads :: Set (Async m ())
carThreads = Set (Async m ())
forall a. Set a
Set.empty,
          carTrace :: Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   = WithAddr addr ErrorPolicyTrace
-> Maybe (WithAddr addr ErrorPolicyTrace)
forall a. a -> Maybe a
Just
                        (addr -> ErrorPolicyTrace -> WithAddr addr ErrorPolicyTrace
forall addr a. addr -> a -> WithAddr addr a
WithAddr addr
addr
                          (SomeException -> ErrorPolicyTrace
ErrorPolicyUnhandledApplicationException
                            (e -> SomeException
forall e. (Exception e, HasExceptionContext) => e -> SomeException
SomeException e
e)))
        }
    -- the error was classified; act with the 'SuspendDecision' on the state
    -- and find threads to cancel.
    Just SuspendDecision DiffTime
cmd -> case Time
-> addr
-> e
-> SuspendDecision DiffTime
-> PeerStates m addr
-> (PeerStates m addr, Set (Async m ()))
forall (m :: * -> *) addr e.
(Ord addr, Ord (Async m ()), Exception e) =>
Time
-> addr
-> e
-> SuspendDecision DiffTime
-> PeerStates m addr
-> (PeerStates m addr, Set (Async m ()))
runSuspendDecision Time
t addr
addr e
e SuspendDecision DiffTime
cmd PeerStates m addr
ps of
      (PeerStates m addr
ps', Set (Async m ())
threads) ->
        CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompleteApplicationResult m addr (PeerStates m addr)
 -> STM m (CompleteApplicationResult m addr (PeerStates m addr)))
-> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a b. (a -> b) -> a -> b
$
          CompleteApplicationResult {
              carState :: PeerStates m addr
carState   = PeerStates m addr
ps',
              carThreads :: Set (Async m ())
carThreads = Set (Async m ())
threads,
              carTrace :: Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   = addr -> ErrorPolicyTrace -> WithAddr addr ErrorPolicyTrace
forall addr a. addr -> a -> WithAddr addr a
WithAddr addr
addr (ErrorPolicyTrace -> WithAddr addr ErrorPolicyTrace)
-> Maybe ErrorPolicyTrace -> Maybe (WithAddr addr ErrorPolicyTrace)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            Either (ConnectionOrApplicationExceptionTrace SomeException) Any
-> SuspendDecision DiffTime -> Maybe ErrorPolicyTrace
forall r.
Either (ConnectionOrApplicationExceptionTrace SomeException) r
-> SuspendDecision DiffTime -> Maybe ErrorPolicyTrace
traceErrorPolicy
                              (ConnectionOrApplicationExceptionTrace SomeException
-> Either (ConnectionOrApplicationExceptionTrace SomeException) Any
forall a b. a -> Either a b
Left (ConnectionOrApplicationExceptionTrace SomeException
 -> Either
      (ConnectionOrApplicationExceptionTrace SomeException) Any)
-> ConnectionOrApplicationExceptionTrace SomeException
-> Either (ConnectionOrApplicationExceptionTrace SomeException) Any
forall a b. (a -> b) -> a -> b
$ SomeException
-> ConnectionOrApplicationExceptionTrace SomeException
forall err. err -> ConnectionOrApplicationExceptionTrace err
ApplicationExceptionTrace (e -> SomeException
forall e. (Exception e, HasExceptionContext) => e -> SomeException
SomeException e
e))
                              SuspendDecision DiffTime
cmd
            }

-- we connected to a peer; this does not require to update the 'PeerState'.
completeApplicationTx ErrorPolicies
_ (Connected Time
_t  addr
_addr) PeerStates m addr
ps =
    CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompleteApplicationResult m addr (PeerStates m addr)
 -> STM m (CompleteApplicationResult m addr (PeerStates m addr)))
-> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a b. (a -> b) -> a -> b
$
      CompleteApplicationResult {
          carState :: PeerStates m addr
carState   = PeerStates m addr
ps,
          carThreads :: Set (Async m ())
carThreads = Set (Async m ())
forall a. Set a
Set.empty,
          carTrace :: Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   = Maybe (WithAddr addr ErrorPolicyTrace)
forall a. Maybe a
Nothing
        }

-- error raised by the 'connect' call
completeApplicationTx ErrorPolicies {[ErrorPolicy]
epConErrorPolicies :: ErrorPolicies -> [ErrorPolicy]
epConErrorPolicies :: [ErrorPolicy]
epConErrorPolicies} (ConnectionError Time
t addr
addr e
e) PeerStates m addr
ps =
  case e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
forall e.
Exception e =>
e -> [ErrorPolicy] -> Maybe (SuspendDecision DiffTime)
evalErrorPolicies e
e [ErrorPolicy]
epConErrorPolicies of
    Maybe (SuspendDecision DiffTime)
Nothing  ->
      let fn :: PeerState m -> Maybe (PeerState m)
fn p :: PeerState m
p@(HotPeer Set (Async m ())
producers Set (Async m ())
consumers)
             | Set (Async m ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async m ())
producers Bool -> Bool -> Bool
&& Set (Async m ()) -> Bool
forall a. Set a -> Bool
Set.null Set (Async m ())
consumers
             = PeerState m -> Maybe (PeerState m)
forall a. a -> Maybe a
Just PeerState m
forall (m :: * -> *). PeerState m
ColdPeer
             | Bool
otherwise
             = PeerState m -> Maybe (PeerState m)
forall a. a -> Maybe a
Just PeerState m
p
          fn PeerState m
p = PeerState m -> Maybe (PeerState m)
forall a. a -> Maybe a
Just PeerState m
p

      in CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompleteApplicationResult m addr (PeerStates m addr)
 -> STM m (CompleteApplicationResult m addr (PeerStates m addr)))
-> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a b. (a -> b) -> a -> b
$
          CompleteApplicationResult {
              carState :: PeerStates m addr
carState =
                case PeerStates m addr
ps of
                  PeerStates Map addr (PeerState m)
peerStates -> Map addr (PeerState m) -> PeerStates m addr
forall addr (m :: * -> *).
Map addr (PeerState m) -> PeerStates m addr
PeerStates (Map addr (PeerState m) -> PeerStates m addr)
-> Map addr (PeerState m) -> PeerStates m addr
forall a b. (a -> b) -> a -> b
$ (PeerState m -> Maybe (PeerState m))
-> addr -> Map addr (PeerState m) -> Map addr (PeerState m)
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update PeerState m -> Maybe (PeerState m)
forall {m :: * -> *}. PeerState m -> Maybe (PeerState m)
fn addr
addr Map addr (PeerState m)
peerStates
#if __GLASGOW_HASKELL__ < 900
                  -- GHC 9 is certain this pattern is
                  -- not used. GHC 8 apparently can't
                  -- agree. m(
                  ThrowException{}      -> ps
#endif
              , carThreads :: Set (Async m ())
carThreads = Set (Async m ())
forall a. Set a
Set.empty
              , carTrace :: Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   = WithAddr addr ErrorPolicyTrace
-> Maybe (WithAddr addr ErrorPolicyTrace)
forall a. a -> Maybe a
Just (WithAddr addr ErrorPolicyTrace
 -> Maybe (WithAddr addr ErrorPolicyTrace))
-> WithAddr addr ErrorPolicyTrace
-> Maybe (WithAddr addr ErrorPolicyTrace)
forall a b. (a -> b) -> a -> b
$
                            addr -> ErrorPolicyTrace -> WithAddr addr ErrorPolicyTrace
forall addr a. addr -> a -> WithAddr addr a
WithAddr addr
addr
                             (SomeException -> ErrorPolicyTrace
ErrorPolicyUnhandledConnectionException
                               (e -> SomeException
forall e. (Exception e, HasExceptionContext) => e -> SomeException
SomeException e
e))
            }
    Just SuspendDecision DiffTime
cmd -> case Time
-> addr
-> e
-> SuspendDecision DiffTime
-> PeerStates m addr
-> (PeerStates m addr, Set (Async m ()))
forall (m :: * -> *) addr e.
(Ord addr, Ord (Async m ()), Exception e) =>
Time
-> addr
-> e
-> SuspendDecision DiffTime
-> PeerStates m addr
-> (PeerStates m addr, Set (Async m ()))
runSuspendDecision Time
t addr
addr e
e SuspendDecision DiffTime
cmd PeerStates m addr
ps of
      (PeerStates m addr
ps', Set (Async m ())
threads) ->
        CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompleteApplicationResult m addr (PeerStates m addr)
 -> STM m (CompleteApplicationResult m addr (PeerStates m addr)))
-> CompleteApplicationResult m addr (PeerStates m addr)
-> STM m (CompleteApplicationResult m addr (PeerStates m addr))
forall a b. (a -> b) -> a -> b
$
          CompleteApplicationResult {
              carState :: PeerStates m addr
carState   = PeerStates m addr
ps',
              carThreads :: Set (Async m ())
carThreads = Set (Async m ())
threads,
              carTrace :: Maybe (WithAddr addr ErrorPolicyTrace)
carTrace   = addr -> ErrorPolicyTrace -> WithAddr addr ErrorPolicyTrace
forall addr a. addr -> a -> WithAddr addr a
WithAddr addr
addr (ErrorPolicyTrace -> WithAddr addr ErrorPolicyTrace)
-> Maybe ErrorPolicyTrace -> Maybe (WithAddr addr ErrorPolicyTrace)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                           (Either (ConnectionOrApplicationExceptionTrace SomeException) Any
-> SuspendDecision DiffTime -> Maybe ErrorPolicyTrace
forall r.
Either (ConnectionOrApplicationExceptionTrace SomeException) r
-> SuspendDecision DiffTime -> Maybe ErrorPolicyTrace
traceErrorPolicy
                             (ConnectionOrApplicationExceptionTrace SomeException
-> Either (ConnectionOrApplicationExceptionTrace SomeException) Any
forall a b. a -> Either a b
Left (ConnectionOrApplicationExceptionTrace SomeException
 -> Either
      (ConnectionOrApplicationExceptionTrace SomeException) Any)
-> ConnectionOrApplicationExceptionTrace SomeException
-> Either (ConnectionOrApplicationExceptionTrace SomeException) Any
forall a b. (a -> b) -> a -> b
$ SomeException
-> ConnectionOrApplicationExceptionTrace SomeException
forall err. err -> ConnectionOrApplicationExceptionTrace err
ConnectionExceptionTrace (e -> SomeException
forall e. (Exception e, HasExceptionContext) => e -> SomeException
SomeException e
e))
                             SuspendDecision DiffTime
cmd)
            }

--
-- Traces
--

-- | Trace data for error policies
data ErrorPolicyTrace
  = ErrorPolicySuspendPeer (Maybe (ConnectionOrApplicationExceptionTrace SomeException)) DiffTime DiffTime
  -- ^ suspending peer with a given exception until
  | ErrorPolicySuspendConsumer (Maybe (ConnectionOrApplicationExceptionTrace SomeException)) DiffTime
  -- ^ suspending consumer until
  | ErrorPolicyLocalNodeError (ConnectionOrApplicationExceptionTrace SomeException)
  -- ^ caught a local exception
  | ErrorPolicyResumePeer
  -- ^ resume a peer (both consumer and producer)
  | ErrorPolicyKeepSuspended
  -- ^ consumer was suspended until producer will resume
  | ErrorPolicyResumeConsumer
  -- ^ resume consumer
  | ErrorPolicyResumeProducer
  -- ^ resume producer
  | ErrorPolicyUnhandledApplicationException SomeException
  -- ^ an application throwed an exception, which was not handled by any
  -- 'ErrorPolicy'.
  | ErrorPolicyUnhandledConnectionException SomeException
  -- ^ 'connect' throwed an exception, which was not handled by any
  -- 'ErrorPolicy'.
  | ErrorPolicyAcceptException IOException
  -- ^ 'accept' throwed an exception
  deriving Int -> ErrorPolicyTrace -> ShowS
[ErrorPolicyTrace] -> ShowS
ErrorPolicyTrace -> String
(Int -> ErrorPolicyTrace -> ShowS)
-> (ErrorPolicyTrace -> String)
-> ([ErrorPolicyTrace] -> ShowS)
-> Show ErrorPolicyTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorPolicyTrace -> ShowS
showsPrec :: Int -> ErrorPolicyTrace -> ShowS
$cshow :: ErrorPolicyTrace -> String
show :: ErrorPolicyTrace -> String
$cshowList :: [ErrorPolicyTrace] -> ShowS
showList :: [ErrorPolicyTrace] -> ShowS
Show

traceErrorPolicy :: Either (ConnectionOrApplicationExceptionTrace SomeException) r
                 -> SuspendDecision DiffTime
                 -> Maybe ErrorPolicyTrace
traceErrorPolicy :: forall r.
Either (ConnectionOrApplicationExceptionTrace SomeException) r
-> SuspendDecision DiffTime -> Maybe ErrorPolicyTrace
traceErrorPolicy (Left ConnectionOrApplicationExceptionTrace SomeException
e) (SuspendPeer DiffTime
prodT DiffTime
consT) =
    ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a. a -> Maybe a
Just (ErrorPolicyTrace -> Maybe ErrorPolicyTrace)
-> ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a b. (a -> b) -> a -> b
$ Maybe (ConnectionOrApplicationExceptionTrace SomeException)
-> DiffTime -> DiffTime -> ErrorPolicyTrace
ErrorPolicySuspendPeer (ConnectionOrApplicationExceptionTrace SomeException
-> Maybe (ConnectionOrApplicationExceptionTrace SomeException)
forall a. a -> Maybe a
Just ConnectionOrApplicationExceptionTrace SomeException
e) DiffTime
prodT DiffTime
consT
traceErrorPolicy (Right r
_) (SuspendPeer DiffTime
prodT DiffTime
consT) =
    ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a. a -> Maybe a
Just (ErrorPolicyTrace -> Maybe ErrorPolicyTrace)
-> ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a b. (a -> b) -> a -> b
$ Maybe (ConnectionOrApplicationExceptionTrace SomeException)
-> DiffTime -> DiffTime -> ErrorPolicyTrace
ErrorPolicySuspendPeer Maybe (ConnectionOrApplicationExceptionTrace SomeException)
forall a. Maybe a
Nothing DiffTime
prodT DiffTime
consT
traceErrorPolicy (Left ConnectionOrApplicationExceptionTrace SomeException
e) (SuspendConsumer DiffTime
consT) =
    ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a. a -> Maybe a
Just (ErrorPolicyTrace -> Maybe ErrorPolicyTrace)
-> ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a b. (a -> b) -> a -> b
$ Maybe (ConnectionOrApplicationExceptionTrace SomeException)
-> DiffTime -> ErrorPolicyTrace
ErrorPolicySuspendConsumer (ConnectionOrApplicationExceptionTrace SomeException
-> Maybe (ConnectionOrApplicationExceptionTrace SomeException)
forall a. a -> Maybe a
Just ConnectionOrApplicationExceptionTrace SomeException
e) DiffTime
consT
traceErrorPolicy (Right r
_) (SuspendConsumer DiffTime
consT) =
    ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a. a -> Maybe a
Just (ErrorPolicyTrace -> Maybe ErrorPolicyTrace)
-> ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a b. (a -> b) -> a -> b
$ Maybe (ConnectionOrApplicationExceptionTrace SomeException)
-> DiffTime -> ErrorPolicyTrace
ErrorPolicySuspendConsumer Maybe (ConnectionOrApplicationExceptionTrace SomeException)
forall a. Maybe a
Nothing DiffTime
consT
traceErrorPolicy (Left ConnectionOrApplicationExceptionTrace SomeException
e) SuspendDecision DiffTime
Throw =
    ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a. a -> Maybe a
Just (ErrorPolicyTrace -> Maybe ErrorPolicyTrace)
-> ErrorPolicyTrace -> Maybe ErrorPolicyTrace
forall a b. (a -> b) -> a -> b
$ ConnectionOrApplicationExceptionTrace SomeException
-> ErrorPolicyTrace
ErrorPolicyLocalNodeError ConnectionOrApplicationExceptionTrace SomeException
e
traceErrorPolicy Either (ConnectionOrApplicationExceptionTrace SomeException) r
_ SuspendDecision DiffTime
_ =
    Maybe ErrorPolicyTrace
forall a. Maybe a
Nothing

data WithAddr addr a = WithAddr {
      forall addr a. WithAddr addr a -> addr
wiaAddr  :: addr
    , forall addr a. WithAddr addr a -> a
wiaEvent :: a
    }

instance (Show addr, Show a) => Show (WithAddr addr a) where
    show :: WithAddr addr a -> String
show WithAddr { addr
wiaAddr :: forall addr a. WithAddr addr a -> addr
wiaAddr :: addr
wiaAddr, a
wiaEvent :: forall addr a. WithAddr addr a -> a
wiaEvent :: a
wiaEvent } =
        String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"IP %s %s" (addr -> String
forall a. Show a => a -> String
show addr
wiaAddr) (a -> String
forall a. Show a => a -> String
show a
wiaEvent)