{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Wallet.Registry
    ( -- * Worker Registry
      WorkerRegistry
    , empty
    , lookup
    , register
    , unregister

      -- * Worker
    , Worker
    , MkWorker(..)
    , defaultWorkerAfter
    , workerThread
    , workerId
    , workerResource

      -- * Context
    , HasWorkerCtx (..)

      -- * Logging
    , WorkerLog (..)
    , AfterThreadLog (..)
    , traceAfterThread
    ) where

import Prelude hiding
    ( log, lookup )

import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.Wallet
    ( HasLogger, logger )
import Cardano.Wallet.Logging
    ( LoggedException (..) )
import Control.Monad
    ( void )
import Control.Monad.IO.Class
    ( MonadIO, liftIO )
import Control.Tracer
    ( Tracer, contramap, traceWith )
import Data.Foldable
    ( traverse_ )
import Data.Generics.Internal.VL.Lens
    ( (^.) )
import Data.Generics.Labels
    ()
import Data.Generics.Product.Typed
    ( HasType )
import Data.Kind
    ( Type )
import Data.Map.Strict
    ( Map )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Text.Class
    ( ToText (..) )
import GHC.Generics
    ( Generic )
import UnliftIO.Concurrent
    ( ThreadId, forkFinally, killThread )
import UnliftIO.Exception
    ( SomeException, isSyncException, withException )
import UnliftIO.MVar
    ( MVar
    , modifyMVar_
    , newEmptyMVar
    , newMVar
    , putMVar
    , readMVar
    , takeMVar
    , tryPutMVar
    )

{-------------------------------------------------------------------------------
                                Worker Context
-------------------------------------------------------------------------------}

-- | A class to link an existing context to a worker context.
class HasType resource (WorkerCtx ctx) => HasWorkerCtx resource ctx where
    type WorkerCtx ctx :: Type
    type WorkerMsg ctx :: Type
    type WorkerKey ctx :: Type
    hoistResource
        :: resource
        -> (WorkerMsg ctx -> WorkerLog (WorkerKey ctx) (WorkerMsg ctx))
        -> ctx
        -> WorkerCtx ctx

{-------------------------------------------------------------------------------
                                Worker Registry
-------------------------------------------------------------------------------}

-- | A registry to keep track of worker threads and acquired resources.
newtype WorkerRegistry key resource =
    WorkerRegistry (MVar (Map key (Worker key resource)))

-- | Construct a new empty registry
empty
    :: Ord key => IO (WorkerRegistry key resource)
empty :: IO (WorkerRegistry key resource)
empty =
    MVar (Map key (Worker key resource)) -> WorkerRegistry key resource
forall key resource.
MVar (Map key (Worker key resource)) -> WorkerRegistry key resource
WorkerRegistry (MVar (Map key (Worker key resource))
 -> WorkerRegistry key resource)
-> IO (MVar (Map key (Worker key resource)))
-> IO (WorkerRegistry key resource)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map key (Worker key resource)
-> IO (MVar (Map key (Worker key resource)))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Map key (Worker key resource)
forall a. Monoid a => a
mempty

-- | Lookup the registry for a given worker
lookup
    :: (MonadIO m, Ord key)
    => WorkerRegistry key resource
    -> key
    -> m (Maybe (Worker key resource))
lookup :: WorkerRegistry key resource
-> key -> m (Maybe (Worker key resource))
lookup (WorkerRegistry MVar (Map key (Worker key resource))
mvar) key
k =
    IO (Maybe (Worker key resource)) -> m (Maybe (Worker key resource))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (key -> Map key (Worker key resource) -> Maybe (Worker key resource)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
k (Map key (Worker key resource) -> Maybe (Worker key resource))
-> IO (Map key (Worker key resource))
-> IO (Maybe (Worker key resource))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map key (Worker key resource))
-> IO (Map key (Worker key resource))
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (Map key (Worker key resource))
mvar)

-- | Register a new worker
insert
    :: Ord key
    => WorkerRegistry key resource
    -> Worker key resource
    -> IO ()
insert :: WorkerRegistry key resource -> Worker key resource -> IO ()
insert (WorkerRegistry MVar (Map key (Worker key resource))
mvar) Worker key resource
wrk =
    MVar (Map key (Worker key resource))
-> (Map key (Worker key resource)
    -> IO (Map key (Worker key resource)))
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Map key (Worker key resource))
mvar (Map key (Worker key resource) -> IO (Map key (Worker key resource))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map key (Worker key resource)
 -> IO (Map key (Worker key resource)))
-> (Map key (Worker key resource) -> Map key (Worker key resource))
-> Map key (Worker key resource)
-> IO (Map key (Worker key resource))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. key
-> Worker key resource
-> Map key (Worker key resource)
-> Map key (Worker key resource)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Worker key resource -> key
forall key resource. Worker key resource -> key
workerId Worker key resource
wrk) Worker key resource
wrk)

-- | Delete a worker from the registry, but don't cancel the running task.
--
delete
    :: Ord key
    => WorkerRegistry key resource
    -> key
    -> IO (Maybe (Worker key resource))
delete :: WorkerRegistry key resource
-> key -> IO (Maybe (Worker key resource))
delete (WorkerRegistry MVar (Map key (Worker key resource))
mvar) key
k = do
    Maybe (Worker key resource)
mWorker <- key -> Map key (Worker key resource) -> Maybe (Worker key resource)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup key
k (Map key (Worker key resource) -> Maybe (Worker key resource))
-> IO (Map key (Worker key resource))
-> IO (Maybe (Worker key resource))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map key (Worker key resource))
-> IO (Map key (Worker key resource))
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (Map key (Worker key resource))
mvar
    MVar (Map key (Worker key resource))
-> (Map key (Worker key resource)
    -> IO (Map key (Worker key resource)))
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar (Map key (Worker key resource))
mvar (Map key (Worker key resource) -> IO (Map key (Worker key resource))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map key (Worker key resource)
 -> IO (Map key (Worker key resource)))
-> (Map key (Worker key resource) -> Map key (Worker key resource))
-> Map key (Worker key resource)
-> IO (Map key (Worker key resource))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. key
-> Map key (Worker key resource) -> Map key (Worker key resource)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete key
k)
    Maybe (Worker key resource) -> IO (Maybe (Worker key resource))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Worker key resource)
mWorker

-- | Unregister a worker from the registry, terminating the running task.
--
unregister
    :: Ord key
    => WorkerRegistry key resource
    -> key
    -> IO ()
unregister :: WorkerRegistry key resource -> key -> IO ()
unregister WorkerRegistry key resource
registry key
k =
    WorkerRegistry key resource
-> key -> IO (Maybe (Worker key resource))
forall key resource.
Ord key =>
WorkerRegistry key resource
-> key -> IO (Maybe (Worker key resource))
delete WorkerRegistry key resource
registry key
k IO (Maybe (Worker key resource))
-> (Maybe (Worker key resource) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Worker key resource -> IO ())
-> Maybe (Worker key resource) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread (ThreadId -> IO ())
-> (Worker key resource -> ThreadId)
-> Worker key resource
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Worker key resource -> ThreadId
forall key resource. Worker key resource -> ThreadId
workerThread)

{-------------------------------------------------------------------------------
                                    Worker
-------------------------------------------------------------------------------}

-- | A worker which holds and manipulate a particular acquired resource. That
-- resource can be, for example, a handle to a database connection.
data Worker key resource = Worker
    { Worker key resource -> key
workerId :: key
    , Worker key resource -> ThreadId
workerThread :: ThreadId
    , Worker key resource -> resource
workerResource :: resource
    } deriving ((forall x. Worker key resource -> Rep (Worker key resource) x)
-> (forall x. Rep (Worker key resource) x -> Worker key resource)
-> Generic (Worker key resource)
forall x. Rep (Worker key resource) x -> Worker key resource
forall x. Worker key resource -> Rep (Worker key resource) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall key resource x.
Rep (Worker key resource) x -> Worker key resource
forall key resource x.
Worker key resource -> Rep (Worker key resource) x
$cto :: forall key resource x.
Rep (Worker key resource) x -> Worker key resource
$cfrom :: forall key resource x.
Worker key resource -> Rep (Worker key resource) x
Generic)

-- | See 'register'
data MkWorker key resource msg ctx = MkWorker
    { MkWorker key resource msg ctx -> WorkerCtx ctx -> key -> IO ()
workerBefore :: WorkerCtx ctx -> key -> IO ()
        -- ^ A task to execute before the main worker's task. When creating a
        -- worker, this task is guaranteed to have terminated once 'register'
        -- returns.
    , MkWorker key resource msg ctx -> WorkerCtx ctx -> key -> IO ()
workerMain :: WorkerCtx ctx -> key -> IO ()
        -- ^ A task for the worker, possibly infinite
    , MkWorker key resource msg ctx
-> Tracer IO (WorkerLog key msg)
-> Either SomeException ()
-> IO ()
workerAfter
        :: Tracer IO (WorkerLog key msg) -> Either SomeException () -> IO ()
        -- ^ Action to run when the worker exits. It will be run
        --   * when the 'workerMain' action exits (successfully or not)
        --   * if 'workerAcquire' fails
        --   * or if the 'workerBefore' action throws an exception.
    , MkWorker key resource msg ctx -> (resource -> IO ()) -> IO ()
workerAcquire :: (resource -> IO ()) -> IO ()
        -- ^ A bracket-style factory to acquire a resource
    }

defaultWorkerAfter
    :: Tracer IO (WorkerLog key msg)
    -> Either SomeException a
    -> IO ()
defaultWorkerAfter :: Tracer IO (WorkerLog key msg) -> Either SomeException a -> IO ()
defaultWorkerAfter Tracer IO (WorkerLog key msg)
tr = Tracer IO AfterThreadLog -> Either SomeException a -> IO ()
forall (m :: * -> *) a.
Tracer m AfterThreadLog -> Either SomeException a -> m ()
traceAfterThread ((AfterThreadLog -> WorkerLog key msg)
-> Tracer IO (WorkerLog key msg) -> Tracer IO AfterThreadLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap AfterThreadLog -> WorkerLog key msg
forall key msg. AfterThreadLog -> WorkerLog key msg
MsgThreadAfter Tracer IO (WorkerLog key msg)
tr)

-- | Register a new worker for a given key.
--
-- A worker maintains an acquired resource. It expects a task as an argument
-- and will terminate as soon as its task is over. In practice, we provide a
-- never-ending task that keeps the worker alive forever.
--
-- Returns 'Nothing' if the worker fails to acquire the necessary resource or
-- terminates unexpectedly before entering its 'main' action.
--
register
    :: forall resource ctx key msg.
        ( Ord key
        , key ~ WorkerKey ctx
        , msg ~ WorkerMsg ctx
        , HasLogger IO (WorkerLog key msg) ctx
        , HasWorkerCtx resource ctx
        )
    => WorkerRegistry key resource
    -> ctx
    -> key
    -> MkWorker key resource msg ctx
    -> IO (Maybe (Worker key resource))
register :: WorkerRegistry key resource
-> ctx
-> key
-> MkWorker key resource msg ctx
-> IO (Maybe (Worker key resource))
register WorkerRegistry key resource
registry ctx
ctx key
k (MkWorker WorkerCtx ctx -> key -> IO ()
before WorkerCtx ctx -> key -> IO ()
main Tracer IO (WorkerLog key msg) -> Either SomeException () -> IO ()
after (resource -> IO ()) -> IO ()
acquire) = do
    MVar (Maybe resource)
resourceVar <- IO (MVar (Maybe resource))
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
    let work :: IO ()
work = (resource -> IO ()) -> IO ()
acquire ((resource -> IO ()) -> IO ()) -> (resource -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \resource
resource -> do
            let ctx' :: WorkerCtx ctx
ctx' = resource
-> (WorkerMsg ctx -> WorkerLog (WorkerKey ctx) (WorkerMsg ctx))
-> ctx
-> WorkerCtx ctx
forall resource ctx.
HasWorkerCtx resource ctx =>
resource
-> (WorkerMsg ctx -> WorkerLog (WorkerKey ctx) (WorkerMsg ctx))
-> ctx
-> WorkerCtx ctx
hoistResource resource
resource (key -> msg -> WorkerLog key msg
forall key msg. key -> msg -> WorkerLog key msg
MsgFromWorker key
k) ctx
ctx
            WorkerCtx ctx -> key -> IO ()
before WorkerCtx ctx
ctx' key
k IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
`withException` (Tracer IO (WorkerLog key msg) -> Either SomeException () -> IO ()
after Tracer IO (WorkerLog key msg)
tr (Either SomeException () -> IO ())
-> (SomeException -> Either SomeException ())
-> SomeException
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException ()
forall a b. a -> Either a b
Left)
            MVar (Maybe resource) -> Maybe resource -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar (Maybe resource)
resourceVar (resource -> Maybe resource
forall a. a -> Maybe a
Just resource
resource)
            WorkerCtx ctx -> key -> IO ()
main WorkerCtx ctx
ctx' key
k
    ThreadId
threadId <- IO ()
work IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
`forkFinally` MVar (Maybe resource) -> Either SomeException () -> IO ()
cleanup MVar (Maybe resource)
resourceVar
    MVar (Maybe resource) -> IO (Maybe resource)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar (Maybe resource)
resourceVar IO (Maybe resource)
-> (Maybe resource -> IO (Maybe (Worker key resource)))
-> IO (Maybe (Worker key resource))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (resource -> IO (Worker key resource))
-> Maybe resource -> IO (Maybe (Worker key resource))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ThreadId -> resource -> IO (Worker key resource)
create ThreadId
threadId)
  where
    tr :: Tracer IO (WorkerLog key msg)
tr = ctx
ctx ctx
-> ((Tracer IO (WorkerLog key msg)
     -> Const
          (Tracer IO (WorkerLog key msg)) (Tracer IO (WorkerLog key msg)))
    -> ctx -> Const (Tracer IO (WorkerLog key msg)) ctx)
-> Tracer IO (WorkerLog key msg)
forall s a. s -> ((a -> Const a a) -> s -> Const a s) -> a
^. forall ctx.
HasLogger IO (WorkerLog key msg) ctx =>
Lens' ctx (Tracer IO (WorkerLog key msg))
forall (m :: * -> *) msg ctx.
HasLogger m msg ctx =>
Lens' ctx (Tracer m msg)
logger @IO @(WorkerLog key msg)
    create :: ThreadId -> resource -> IO (Worker key resource)
create ThreadId
threadId resource
resource = do
        let worker :: Worker key resource
worker = Worker :: forall key resource.
key -> ThreadId -> resource -> Worker key resource
Worker
                { workerId :: key
workerId = key
k
                , workerThread :: ThreadId
workerThread = ThreadId
threadId
                , workerResource :: resource
workerResource = resource
resource
                }
        WorkerRegistry key resource
registry WorkerRegistry key resource -> Worker key resource -> IO ()
forall key resource.
Ord key =>
WorkerRegistry key resource -> Worker key resource -> IO ()
`insert` Worker key resource
worker
        Worker key resource -> IO (Worker key resource)
forall (m :: * -> *) a. Monad m => a -> m a
return Worker key resource
worker
    cleanup :: MVar (Maybe resource) -> Either SomeException () -> IO ()
cleanup MVar (Maybe resource)
resourceVar Either SomeException ()
result = do
        IO (Maybe (Worker key resource)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (Worker key resource)) -> IO ())
-> IO (Maybe (Worker key resource)) -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkerRegistry key resource
registry WorkerRegistry key resource
-> key -> IO (Maybe (Worker key resource))
forall key resource.
Ord key =>
WorkerRegistry key resource
-> key -> IO (Maybe (Worker key resource))
`delete` key
k
        IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Maybe resource) -> Maybe resource -> IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar (Maybe resource)
resourceVar Maybe resource
forall a. Maybe a
Nothing
        Tracer IO (WorkerLog key msg) -> Either SomeException () -> IO ()
after Tracer IO (WorkerLog key msg)
tr Either SomeException ()
result

{-------------------------------------------------------------------------------
                                    Logging
-------------------------------------------------------------------------------}

-- | Log messages relating to a registry worker thread.
data WorkerLog key msg
    = MsgThreadAfter AfterThreadLog
    | MsgFromWorker key msg
    deriving (Int -> WorkerLog key msg -> ShowS
[WorkerLog key msg] -> ShowS
WorkerLog key msg -> String
(Int -> WorkerLog key msg -> ShowS)
-> (WorkerLog key msg -> String)
-> ([WorkerLog key msg] -> ShowS)
-> Show (WorkerLog key msg)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall key msg.
(Show key, Show msg) =>
Int -> WorkerLog key msg -> ShowS
forall key msg.
(Show key, Show msg) =>
[WorkerLog key msg] -> ShowS
forall key msg. (Show key, Show msg) => WorkerLog key msg -> String
showList :: [WorkerLog key msg] -> ShowS
$cshowList :: forall key msg.
(Show key, Show msg) =>
[WorkerLog key msg] -> ShowS
show :: WorkerLog key msg -> String
$cshow :: forall key msg. (Show key, Show msg) => WorkerLog key msg -> String
showsPrec :: Int -> WorkerLog key msg -> ShowS
$cshowsPrec :: forall key msg.
(Show key, Show msg) =>
Int -> WorkerLog key msg -> ShowS
Show, WorkerLog key msg -> WorkerLog key msg -> Bool
(WorkerLog key msg -> WorkerLog key msg -> Bool)
-> (WorkerLog key msg -> WorkerLog key msg -> Bool)
-> Eq (WorkerLog key msg)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall key msg.
(Eq key, Eq msg) =>
WorkerLog key msg -> WorkerLog key msg -> Bool
/= :: WorkerLog key msg -> WorkerLog key msg -> Bool
$c/= :: forall key msg.
(Eq key, Eq msg) =>
WorkerLog key msg -> WorkerLog key msg -> Bool
== :: WorkerLog key msg -> WorkerLog key msg -> Bool
$c== :: forall key msg.
(Eq key, Eq msg) =>
WorkerLog key msg -> WorkerLog key msg -> Bool
Eq)

instance (ToText key, ToText msg) => ToText (WorkerLog key msg) where
    toText :: WorkerLog key msg -> Text
toText = \case
        MsgThreadAfter AfterThreadLog
msg ->
            Text
"Worker has exited: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AfterThreadLog -> Text
forall a. ToText a => a -> Text
toText AfterThreadLog
msg
        MsgFromWorker key
key msg
msg
            | key -> Text
forall a. ToText a => a -> Text
toText key
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty -> msg -> Text
forall a. ToText a => a -> Text
toText msg
msg
            | Bool
otherwise -> Int -> Text -> Text
T.take Int
8 (key -> Text
forall a. ToText a => a -> Text
toText key
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> msg -> Text
forall a. ToText a => a -> Text
toText msg
msg

instance HasPrivacyAnnotation (WorkerLog key msg)
instance HasSeverityAnnotation msg => HasSeverityAnnotation (WorkerLog key msg) where
    getSeverityAnnotation :: WorkerLog key msg -> Severity
getSeverityAnnotation = \case
        MsgThreadAfter AfterThreadLog
msg -> AfterThreadLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation AfterThreadLog
msg
        MsgFromWorker key
_ msg
msg -> msg -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation msg
msg

-- | Log messages describing how a worker thread exits.
data AfterThreadLog
    = MsgThreadFinished
    | MsgThreadCancelled
    | MsgUnhandledException (LoggedException SomeException)
    deriving (Int -> AfterThreadLog -> ShowS
[AfterThreadLog] -> ShowS
AfterThreadLog -> String
(Int -> AfterThreadLog -> ShowS)
-> (AfterThreadLog -> String)
-> ([AfterThreadLog] -> ShowS)
-> Show AfterThreadLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AfterThreadLog] -> ShowS
$cshowList :: [AfterThreadLog] -> ShowS
show :: AfterThreadLog -> String
$cshow :: AfterThreadLog -> String
showsPrec :: Int -> AfterThreadLog -> ShowS
$cshowsPrec :: Int -> AfterThreadLog -> ShowS
Show, AfterThreadLog -> AfterThreadLog -> Bool
(AfterThreadLog -> AfterThreadLog -> Bool)
-> (AfterThreadLog -> AfterThreadLog -> Bool) -> Eq AfterThreadLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AfterThreadLog -> AfterThreadLog -> Bool
$c/= :: AfterThreadLog -> AfterThreadLog -> Bool
== :: AfterThreadLog -> AfterThreadLog -> Bool
$c== :: AfterThreadLog -> AfterThreadLog -> Bool
Eq)

instance ToText AfterThreadLog where
    toText :: AfterThreadLog -> Text
toText = \case
        AfterThreadLog
MsgThreadFinished -> Text
"Action has finished"
        AfterThreadLog
MsgThreadCancelled -> Text
"Thread was cancelled"
        MsgUnhandledException LoggedException SomeException
err -> Text
"Unhandled exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LoggedException SomeException -> Text
forall a. ToText a => a -> Text
toText LoggedException SomeException
err

instance HasPrivacyAnnotation AfterThreadLog
instance HasSeverityAnnotation AfterThreadLog where
    getSeverityAnnotation :: AfterThreadLog -> Severity
getSeverityAnnotation = \case
        AfterThreadLog
MsgThreadFinished -> Severity
Notice
        AfterThreadLog
MsgThreadCancelled -> Severity
Notice
        MsgUnhandledException LoggedException SomeException
_ -> Severity
Error

-- | Trace an 'AfterThreadLog' message from a caught exception.
traceAfterThread
    :: Tracer m AfterThreadLog
    -> Either SomeException a
    -> m ()
traceAfterThread :: Tracer m AfterThreadLog -> Either SomeException a -> m ()
traceAfterThread Tracer m AfterThreadLog
tr = Tracer m AfterThreadLog -> AfterThreadLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m AfterThreadLog
tr (AfterThreadLog -> m ())
-> (Either SomeException a -> AfterThreadLog)
-> Either SomeException a
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Right a
_ -> AfterThreadLog
MsgThreadFinished
    Left SomeException
e -> if SomeException -> Bool
forall e. Exception e => e -> Bool
isSyncException SomeException
e
        then LoggedException SomeException -> AfterThreadLog
MsgUnhandledException (LoggedException SomeException -> AfterThreadLog)
-> LoggedException SomeException -> AfterThreadLog
forall a b. (a -> b) -> a -> b
$ SomeException -> LoggedException SomeException
forall e. e -> LoggedException e
LoggedException SomeException
e
        else AfterThreadLog
MsgThreadCancelled