{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- Description : Interface for implementing EventBackends
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
--
-- This is the primary module needed to write new 'EventBackend's.
module Observe.Event.Backend
  ( -- * Core interface
    EventBackend (..),
    Event (..),
    Reference (..),
    ReferenceType (..),

    -- * Backend composition
    unitEventBackend,
    pairEventBackend,
    noopEventBackend,

    -- * Backend transformation
    hoistEventBackend,
    hoistEvent,
    InjectSelector,
    injectSelector,
    idInjectSelector,
    narrowEventBackend,
    setDefaultReferenceEventBackend,
    setAncestorEventBackend,
    setInitialCauseEventBackend,
    setReferenceEventBackend,
    setParentEventBackend,
    setProximateEventBackend,
  )
where

import Control.Exception
import Control.Monad
import Control.Monad.Primitive
import Data.Functor
import Data.Primitive.MVar

-- | An instrumentation event.
--
-- 'Event's are the core of the instrumenting user's interface
-- to eventuo11y. Typical usage would be to create an 'Event'
-- using v'Observe.Event.withEvent' and add fields to the 'Event' at appropriate
-- points in your code with 'addField'.
--
-- [@m@]: The monad we're instrumenting in.
-- [@r@]: The type of event references. See 'reference'.
-- [@f@]: The type of fields on this event. See 'addField'.
data Event m r f = Event
  { -- | Obtain a reference to an 'Event'.
    --
    -- References are used to link 'Event's together, via 'addReference'.
    --
    -- References can live past when an event has been 'finalize'd.
    --
    -- Code being instrumented should always have @r@ as an unconstrained
    -- type parameter, both because it is an implementation concern for
    -- 'EventBackend's and because references are backend-specific and it
    -- would be an error to reference an event in one backend from an event
    -- in a different backend.
    forall (m :: * -> *) r f. Event m r f -> r
reference :: !r,
    -- | Add a field to an 'Event'.
    --
    -- Fields make up the basic data captured in an event. They should be added
    -- to an 'Event' as the code progresses through various phases of work, and can
    -- be both milestone markers ("we got this far in the process") or more detailed
    -- instrumentation ("we've processed N records").
    --
    -- They are intended to be of a domain specific type per unit of functionality
    -- within an instrumented codebase (but see [DynamicField](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicField)
    -- for a generic option).
    forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField :: !(f -> m ()),
    -- | Relate another 'Event' to this 'Event' in the specified way
    forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference :: !(Reference r -> m ()),
    -- | Mark an 'Event' as finished, perhaps due to an 'Exception'.
    --
    -- In normal usage, this should be automatically called via the use of
    -- the [resource-safe event allocation functions](Observe-Event.html#g:resourcesafe).
    --
    -- This is a no-op if the 'Event' has already been 'finalize'd.
    -- As a result, it is likely pointless to call
    -- 'addField' or 'addReference' (or v'Observe.Event.addParent' / v'Observe.Event.addProximate')
    -- after this call, though it still may be reasonable to call 'reference'.
    forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize :: !(Maybe SomeException -> m ())
  }

-- | Hoist an 'Event' along a given natural transformation into a new monad.
hoistEvent :: (forall x. m x -> n x) -> Event m r f -> Event n r f
hoistEvent :: forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> Event m r f -> Event n r f
hoistEvent forall x. m x -> n x
nt Event m r f
ev =
  Event m r f
ev
    { addField :: f -> n ()
addField = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m r f
ev,
      addReference :: Reference r -> n ()
addReference = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev,
      finalize :: Maybe SomeException -> n ()
finalize = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m r f
ev
    }

-- | Ways in which 'Event's can 'Reference' each other.
data ReferenceType
  = -- | The 'Reference'd 'Event' is a parent of this 'Event'.
    Parent
  | -- | The 'Reference'd 'Event' is a proximate cause of this 'Event'.
    Proximate
  deriving stock (ReferenceType -> ReferenceType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReferenceType -> ReferenceType -> Bool
$c/= :: ReferenceType -> ReferenceType -> Bool
== :: ReferenceType -> ReferenceType -> Bool
$c== :: ReferenceType -> ReferenceType -> Bool
Eq)

-- | A reference to another 'Event'
data Reference r = Reference !ReferenceType !r

-- | A backend for creating t'Event's.
--
-- Different 'EventBackend's will be used to emit instrumentation to
-- different systems. Multiple backends can be combined with
-- 'Observe.Event.pairEventBackend'.
--
-- A simple 'EventBackend' for logging to a t'System.IO.Handle' can be
-- created with 'Observe.Event.Render.IO.JSON.jsonHandleBackend'.
--
-- Typically the entrypoint for some eventuo11y-instrumented code will
-- take an 'EventBackend', polymorphic in @r@ and possibly @m@. Calling
-- code can use 'Observe.Event.subEventBackend' to place the resulting
-- events in its hierarchy.
--
-- From an 'EventBackend', new events can be created via selectors
-- (of type @s f@ for some field type @f@), typically with the
-- [resource-safe allocation functions](Observe-Event.html#g:resourcesafe).
-- Selectors are values which designate the general category of event
-- being created, as well as the type of fields that can be added to it.
-- For example, a web service's selector type may have a @ServicingRequest@
-- constructor, whose field type includes a @ResponseCode@ constructor which
-- records the HTTP status code.
--
-- Selectors are intended to be of a domain specific type per unit of
-- functionality within an instrumented codebase, implemented as a GADT
-- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option).
--
-- Implementations must ensure that 'EventBackend's and their underlying t'Observe.Event.Event's
-- are safe to use across threads.
--
-- [@m@]: The monad we're instrumenting in.
-- [@r@]: The type of event references used in this 'EventBackend'. See 'Observe.Event.reference'.
-- [@s@]: The type of event selectors. See 'newEvent'.
newtype EventBackend m r s = EventBackend
  { -- | Create a new 'Event', selected by the given selector.
    --
    -- The selector specifies the category of new event we're creating, as well
    -- as the type of fields that can be added to it (with 'addField').
    --
    -- Selectors are intended to be of a domain specific type per unit of
    -- functionality within an instrumented codebase, implemented as a GADT
    -- (but see [DynamicEventSelector](https://hackage.haskell.org/package/eventuo11y-json/docs/Observe-Event-Dynamic.html#t:DynamicEventSelector) for a generic option).
    --
    -- Consider the [resource-safe event allocation functions](Observe-Event.html#g:resourcesafe) instead
    -- of calling this directly.
    forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent ::
      forall f.
      -- The event selector.
      s f ->
      m (Event m r f)
  }

-- | A no-op 'EventBackend'.
--
-- This can be used if calling instrumented code from an un-instrumented
-- context, or to purposefully ignore instrumentation from some call.
--
-- 'unitEventBackend' is the algebraic unit of 'pairEventBackend'.
unitEventBackend :: Applicative m => EventBackend m () s
unitEventBackend :: forall (m :: * -> *) (s :: * -> *).
Applicative m =>
EventBackend m () s
unitEventBackend = forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
r -> EventBackend m r s
noopEventBackend ()

-- | An 'EventBackend' which sequentially generates 'Observe.Event.Event's in the two given 'EventBackend's.
--
-- This can be used to emit instrumentation in multiple ways (e.g. logs to grafana and metrics on
-- a prometheus HTML page).
pairEventBackend :: Applicative m => EventBackend m a s -> EventBackend m b s -> EventBackend m (a, b) s
pairEventBackend :: forall (m :: * -> *) a (s :: * -> *) b.
Applicative m =>
EventBackend m a s -> EventBackend m b s -> EventBackend m (a, b) s
pairEventBackend EventBackend m a s
x EventBackend m b s
y =
  EventBackend
    { newEvent :: forall f. s f -> m (Event m (a, b) f)
newEvent = \s f
sel -> do
        Event m a f
xEv <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m a s
x s f
sel
        Event m b f
yEv <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m b s
y s f
sel
        pure $
          Event
            { reference :: (a, b)
reference = (forall (m :: * -> *) r f. Event m r f -> r
reference Event m a f
xEv, forall (m :: * -> *) r f. Event m r f -> r
reference Event m b f
yEv),
              addField :: f -> m ()
addField = \f
f -> forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m a f
xEv f
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m b f
yEv f
f,
              addReference :: Reference (a, b) -> m ()
addReference = \(Reference ReferenceType
ty (a
rx, b
ry)) ->
                forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m a f
xEv (forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
ty a
rx) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m b f
yEv (forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
ty b
ry),
              finalize :: Maybe SomeException -> m ()
finalize = \Maybe SomeException
me -> forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m a f
xEv Maybe SomeException
me forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m b f
yEv Maybe SomeException
me
            }
    }

-- | A no-op 'EventBackend' that can be integrated with other backends.
--
-- This can be used to purposefully ignore instrumentation from some call.
--
-- All events will have the given reference, so can be connected to appropriate
-- events in non-no-op backends, but not in a way that can distinguish between
-- different events from the same no-op backend.
noopEventBackend :: Applicative m => r -> EventBackend m r s
noopEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Applicative m =>
r -> EventBackend m r s
noopEventBackend r
r =
  EventBackend
    { newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
_ ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Event
            { reference :: r
reference = r
r,
              addField :: f -> m ()
addField = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              addReference :: Reference r -> m ()
addReference = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              finalize :: Maybe SomeException -> m ()
finalize = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            }
    }

-- | Hoist an 'EventBackend' along a given natural transformation into a new monad.
hoistEventBackend ::
  (Functor m) =>
  (forall x. m x -> n x) ->
  EventBackend m r s ->
  EventBackend n r s
hoistEventBackend :: forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
Functor m =>
(forall x. m x -> n x) -> EventBackend m r s -> EventBackend n r s
hoistEventBackend forall x. m x -> n x
nt EventBackend m r s
backend =
  EventBackend
    { newEvent :: forall f. s f -> n (Event n r f)
newEvent = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> Event m r f -> Event n r f
hoistEvent forall x. m x -> n x
nt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r s
backend
    }

-- | Inject a narrower selector and its fields into a wider selector.
--
-- See 'injectSelector' for a simple way to construct one of these.
type InjectSelector s t = forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a

-- | Construct an 'InjectSelector' with a straightforward injection from @s@ to @t@
injectSelector :: (forall f. s f -> t f) -> InjectSelector s t
injectSelector :: forall (s :: * -> *) (t :: * -> *).
(forall f. s f -> t f) -> InjectSelector s t
injectSelector forall f. s f -> t f
inj s f
sel forall g. t g -> (f -> g) -> a
withInjField = forall g. t g -> (f -> g) -> a
withInjField (forall f. s f -> t f
inj s f
sel) forall a. a -> a
id

-- | The identity 'InjectSelector'
idInjectSelector :: InjectSelector s s
idInjectSelector :: forall (s :: * -> *). InjectSelector s s
idInjectSelector s f
s forall g. s g -> (f -> g) -> a
go = forall g. s g -> (f -> g) -> a
go s f
s forall a. a -> a
id

-- | Narrow an 'EventBackend' to a new selector type via a given injection function.
--
-- A typical usage, where component A calls component B, would be to have A's selector
-- type have a constructor to take any value of B's selector type (and preserve the field)
-- and then call 'narrowEventBackend' with that constructor when invoking functions in B.
narrowEventBackend ::
  (Functor m) =>
  InjectSelector s t ->
  EventBackend m r t ->
  EventBackend m r s
narrowEventBackend :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
InjectSelector s t -> EventBackend m r t -> EventBackend m r s
narrowEventBackend InjectSelector s t
inj EventBackend m r t
backend =
  EventBackend
    { newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
sel -> InjectSelector s t
inj s f
sel \t g
sel' f -> g
injField ->
        forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r t
backend t g
sel' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Event m r g
ev ->
          Event m r g
ev
            { addField :: f -> m ()
addField = forall (m :: * -> *) r f. Event m r f -> f -> m ()
addField Event m r g
ev forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> g
injField
            }
    }

-- | Transform an 'EventBackend' so all of its 'Event's have a given 'Reference'.
--
-- You likely want 'setDefaultReferenceEventBackend', if your monad supports it.
setReferenceEventBackend :: (Monad m) => Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Monad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend Reference r
r EventBackend m r s
backend =
  EventBackend
    { newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
sel -> do
        Event m r f
ev <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r s
backend s f
sel
        forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev Reference r
r
        pure Event m r f
ev
    }

-- | Transform an 'EventBackend' so all of its 'Event's have a given parent.
--
-- You likely want 'setAncestorEventBackend', if your monad supports it.
setParentEventBackend :: (Monad m) => r -> EventBackend m r s -> EventBackend m r s
setParentEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Monad m =>
r -> EventBackend m r s -> EventBackend m r s
setParentEventBackend = forall (m :: * -> *) r (s :: * -> *).
Monad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Parent

-- | Transform an 'EventBackend' so all of its 'Event's have a given proximate cause.
--
-- You likely want 'setInitialCauseEventBackend', if your monad supports it.
setProximateEventBackend :: (Monad m) => r -> EventBackend m r s -> EventBackend m r s
setProximateEventBackend :: forall (m :: * -> *) r (s :: * -> *).
Monad m =>
r -> EventBackend m r s -> EventBackend m r s
setProximateEventBackend = forall (m :: * -> *) r (s :: * -> *).
Monad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Proximate

-- | Transform an 'EventBackend' so all of its 'Event's have a given 'Reference', if they
-- haven't been given a 'Reference' of the same 'ReferenceType' by the time they are 'finalize'd.
--
-- See 'setReferenceEventBackend' if the 'Reference' should be applied unconditionally.
setDefaultReferenceEventBackend :: (PrimMonad m) => Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend :: forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend ref :: Reference r
ref@(Reference ReferenceType
ty r
_) EventBackend m r s
backend =
  EventBackend
    { newEvent :: forall f. s f -> m (Event m r f)
newEvent = \s f
sel -> do
        MVar (PrimState m) ()
flag <- forall (m :: * -> *) a. PrimMonad m => m (MVar (PrimState m) a)
newEmptyMVar
        Event m r f
ev <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (Event m r f)
newEvent EventBackend m r s
backend s f
sel
        pure $
          Event m r f
ev
            { addReference :: Reference r -> m ()
addReference = \ref' :: Reference r
ref'@(Reference ReferenceType
ty' r
_) -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReferenceType
ty' forall a. Eq a => a -> a -> Bool
== ReferenceType
ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
MVar (PrimState m) a -> a -> m Bool
tryPutMVar MVar (PrimState m) ()
flag ()
                forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev Reference r
ref',
              finalize :: Maybe SomeException -> m ()
finalize = \Maybe SomeException
me -> do
                forall (m :: * -> *) a.
PrimMonad m =>
MVar (PrimState m) a -> a -> m Bool
tryPutMVar MVar (PrimState m) ()
flag () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  Bool
True -> forall (m :: * -> *) r f. Event m r f -> Reference r -> m ()
addReference Event m r f
ev Reference r
ref
                forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m r f
ev Maybe SomeException
me
            }
    }

-- | Transform an 'EventBackend' so all of its 'Event's have a given parent, if they
-- are not given another parent by the time they are 'finalize'd.
--
-- See 'setParentEventBackend' if the parent should be set unconditionally.
setAncestorEventBackend :: (PrimMonad m) => r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend :: forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
r -> EventBackend m r s -> EventBackend m r s
setAncestorEventBackend = forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Parent

-- | Transform an 'EventBackend' so all of its 'Event's have a given proximate cause,
-- if they are not given another proximate cause by the time they are 'finalize'd.
--
-- See 'setProximateEventBackend' if the proximate cause should be set unconditionally.
setInitialCauseEventBackend :: (PrimMonad m) => r -> EventBackend m r s -> EventBackend m r s
setInitialCauseEventBackend :: forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
r -> EventBackend m r s -> EventBackend m r s
setInitialCauseEventBackend = forall (m :: * -> *) r (s :: * -> *).
PrimMonad m =>
Reference r -> EventBackend m r s -> EventBackend m r s
setDefaultReferenceEventBackend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. ReferenceType -> r -> Reference r
Reference ReferenceType
Proximate