{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- 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
  ( EventBackend (..),
    EventImpl (..),
    unitEventBackend,
    pairEventBackend,
    hoistEventBackend,
    hoistEventImpl,
    narrowEventBackend,
    narrowEventBackend',

    -- * OnceFlags

    -- | Generic helper to make operations idempotent.
    OnceFlag (..),
    FlagState (..),
    runOnce,
    hoistOnceFlag,
    alwaysNewOnceFlag,
    newOnceFlagMVar,
  )
where

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

-- | A backend for creating t'Observe.Event.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 t'Observe.Event.Dynamic.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.
data EventBackend m r s = EventBackend
  { -- | Create a new 'EventImpl' corresponding to the given selector.
    forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl :: !(forall f. s f -> m (EventImpl m r f)),
    -- | Allocate a new 'OnceFlag' in our monad.
    forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag :: !(m (OnceFlag m))
  }

-- | The internal implementation of an t'Observe.Event.Event'.
--
-- All fields have corresponding [event manipulation functions](Observe-Event.html#g:eventmanip),
-- except that 'finalizeImpl' and 'failImpl' can assume that they will only ever be called
-- once (i.e., 'EventImpl' implementations do __not__ have to implement locking internally).
data EventImpl m r f = EventImpl
  { forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl :: !r,
    forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl :: !(f -> m ()),
    forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: !(r -> m ()),
    forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl :: !(r -> m ()),
    forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl :: !(m ()),
    forall (m :: * -> *) r f. EventImpl m r f -> SomeException -> m ()
failImpl :: !(SomeException -> m ())
  }

-- | 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 =
  EventBackend
    { newEventImpl :: forall f. s f -> m (EventImpl m () f)
newEventImpl = \s f
_ ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          EventImpl
            { referenceImpl :: ()
referenceImpl = (),
              addFieldImpl :: f -> m ()
addFieldImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              addParentImpl :: () -> m ()
addParentImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              addProximateImpl :: () -> m ()
addProximateImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              finalizeImpl :: m ()
finalizeImpl = forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
              failImpl :: SomeException -> m ()
failImpl = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            },
      newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). Applicative m => OnceFlag m
alwaysNewOnceFlag
    }

-- | 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
    { newEventImpl :: forall f. s f -> m (EventImpl m (a, b) f)
newEventImpl = \s f
sel -> do
        EventImpl m a f
xImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m a s
x s f
sel
        EventImpl m b f
yImpl <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m b s
y s f
sel
        pure $
          EventImpl
            { referenceImpl :: (a, b)
referenceImpl = (forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m a f
xImpl, forall (m :: * -> *) r f. EventImpl m r f -> r
referenceImpl EventImpl m b f
yImpl),
              addFieldImpl :: f -> m ()
addFieldImpl = \f
f -> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m a f
xImpl f
f forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
addFieldImpl EventImpl m b f
yImpl f
f,
              addParentImpl :: (a, b) -> m ()
addParentImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl EventImpl m b f
yImpl b
py,
              addProximateImpl :: (a, b) -> m ()
addProximateImpl = \(a
px, b
py) -> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m a f
xImpl a
px forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addProximateImpl EventImpl m b f
yImpl b
py,
              finalizeImpl :: m ()
finalizeImpl = forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m a f
xImpl forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> m ()
finalizeImpl EventImpl m b f
yImpl,
              failImpl :: SomeException -> m ()
failImpl = \SomeException
e -> forall (m :: * -> *) r f. EventImpl m r f -> SomeException -> m ()
failImpl EventImpl m a f
xImpl SomeException
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) r f. EventImpl m r f -> SomeException -> m ()
failImpl EventImpl m b f
yImpl SomeException
e
            },
      newOnceFlag :: m (OnceFlag m)
newOnceFlag = do
        OnceFlag m
xOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m a s
x
        OnceFlag m
yOnce <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m b s
y
        pure $
          forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag forall a b. (a -> b) -> a -> b
$ do
            FlagState
xSet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
xOnce
            FlagState
ySet <- forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
yOnce
            pure $ case (FlagState
xSet, FlagState
ySet) of
              (FlagState
NewlySet, FlagState
NewlySet) -> FlagState
NewlySet
              (FlagState, FlagState)
_ -> FlagState
AlreadySet
    }

-- | Hoist an 'EventBackend' along a given natural transformation into a new monad.
hoistEventBackend ::
  (Functor m, Functor n) =>
  -- | Natural transformation from @m@ to @n@.
  (forall x. m x -> n x) ->
  EventBackend m r s ->
  EventBackend n r s
hoistEventBackend :: forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
(Functor m, Functor n) =>
(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
    { newEventImpl :: forall f. s f -> n (EventImpl n r f)
newEventImpl = 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) -> EventImpl m r f -> EventImpl n r f
hoistEventImpl 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 (EventImpl m r f)
newEventImpl EventBackend m r s
backend,
      newOnceFlag :: n (OnceFlag n)
newOnceFlag = forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> OnceFlag f -> OnceFlag g
hoistOnceFlag forall x. m x -> n x
nt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. m x -> n x
nt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r s
backend)
    }

-- | Hoist an 'EventImpl' along a given natural transformation into a new monad.
hoistEventImpl :: (forall x. m x -> n x) -> EventImpl m r f -> EventImpl n r f
hoistEventImpl :: forall (m :: * -> *) (n :: * -> *) r f.
(forall x. m x -> n x) -> EventImpl m r f -> EventImpl n r f
hoistEventImpl forall x. m x -> n x
nt (EventImpl {r
m ()
r -> m ()
f -> m ()
SomeException -> m ()
failImpl :: SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: f -> m ()
referenceImpl :: r
failImpl :: forall (m :: * -> *) r f. EventImpl m r f -> SomeException -> m ()
finalizeImpl :: forall (m :: * -> *) r f. EventImpl m r f -> m ()
addProximateImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addFieldImpl :: forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
referenceImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r
..}) =
  EventImpl
    { r
referenceImpl :: r
referenceImpl :: r
referenceImpl,
      addFieldImpl :: f -> n ()
addFieldImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> m ()
addFieldImpl,
      addParentImpl :: r -> n ()
addParentImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addParentImpl,
      addProximateImpl :: r -> n ()
addProximateImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m ()
addProximateImpl,
      finalizeImpl :: n ()
finalizeImpl = forall x. m x -> n x
nt m ()
finalizeImpl,
      failImpl :: SomeException -> n ()
failImpl = forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> m ()
failImpl
    }

-- | 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.
--
-- See 'narrowEventBackend'' for a more general, if unweildy, variant.
narrowEventBackend ::
  (Functor m) =>
  -- | Inject a narrow selector into the wider selector type.
  (forall f. s f -> t f) ->
  EventBackend m r t ->
  EventBackend m r s
narrowEventBackend :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> t f) -> EventBackend m r t -> EventBackend m r s
narrowEventBackend forall f. s f -> t f
inj =
  forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend'
    (\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)

-- | Narrow an 'EventBackend' to a new selector type via a given injection function.
--
-- See 'narrowEventBackend' for a simpler, if less general, variant.
narrowEventBackend' ::
  (Functor m) =>
  -- | Simultaneously inject a narrow selector into the wider selector type
  -- and the narrow selector's field into the wider selector's field type.
  (forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a) ->
  EventBackend m r t ->
  EventBackend m r s
narrowEventBackend' :: forall (m :: * -> *) (s :: * -> *) (t :: * -> *) r.
Functor m =>
(forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a)
-> EventBackend m r t -> EventBackend m r s
narrowEventBackend' forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj EventBackend m r t
backend =
  EventBackend
    { newEventImpl :: forall f. s f -> m (EventImpl m r f)
newEventImpl = \s f
sel -> forall f. s f -> forall a. (forall g. t g -> (f -> g) -> a) -> a
inj s f
sel \t g
sel' f -> g
injField ->
        forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. s f -> m (EventImpl m r f)
newEventImpl EventBackend m r t
backend t g
sel' forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          EventImpl {r
m ()
r -> m ()
g -> m ()
SomeException -> m ()
failImpl :: SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
addFieldImpl :: g -> m ()
referenceImpl :: r
failImpl :: forall (m :: * -> *) r f. EventImpl m r f -> SomeException -> m ()
finalizeImpl :: forall (m :: * -> *) r f. EventImpl m r f -> m ()
addProximateImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addParentImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r -> m ()
addFieldImpl :: forall (m :: * -> *) r f. EventImpl m r f -> f -> m ()
referenceImpl :: forall (m :: * -> *) r f. EventImpl m r f -> r
..} ->
            EventImpl
              { addFieldImpl :: f -> m ()
addFieldImpl = g -> m ()
addFieldImpl forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> g
injField,
                r
m ()
r -> m ()
SomeException -> m ()
failImpl :: SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
failImpl :: SomeException -> m ()
finalizeImpl :: m ()
addProximateImpl :: r -> m ()
addParentImpl :: r -> m ()
referenceImpl :: r
..
              },
      newOnceFlag :: m (OnceFlag m)
newOnceFlag = forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> m (OnceFlag m)
newOnceFlag EventBackend m r t
backend
    }

-- | The state of a 'OnceFlag'
data FlagState
  = -- | The flag was not set, but is now
    NewlySet
  | -- | The flag was already set
    AlreadySet

-- | A flag to ensure only one operation from some class is performed, once.
--
-- Typically consumed via 'runOnce'
newtype OnceFlag m = OnceFlag
  { -- | Get the state of the 'OnceFlag', and set the flag.
    --
    -- This operation should be atomic, and ideally would only
    -- return 'NewlySet' once. In monads that don't support it,
    -- at a minimum it must be monotonic (once one caller gets
    -- 'AlreadySet', all callers will).
    forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet :: m FlagState
  }

-- | Run an operation if no other operations using this
-- 'OnceFlag' have run.
runOnce :: (Monad m) => OnceFlag m -> m () -> m ()
runOnce :: forall (m :: * -> *). Monad m => OnceFlag m -> m () -> m ()
runOnce OnceFlag m
f m ()
go =
  forall (m :: * -> *). OnceFlag m -> m FlagState
checkAndSet OnceFlag m
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    FlagState
NewlySet -> m ()
go
    FlagState
AlreadySet -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A 'OnceFlag' using an 'MVar'.
newOnceFlagMVar :: (PrimMonad m) => m (OnceFlag m)
newOnceFlagMVar :: forall (m :: * -> *). PrimMonad m => m (OnceFlag m)
newOnceFlagMVar = do
  MVar (PrimState m) ()
flag <- forall (m :: * -> *) a. PrimMonad m => m (MVar (PrimState m) a)
newEmptyMVar
  pure $
    forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag 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 (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Bool
False -> FlagState
AlreadySet
        Bool
True -> FlagState
NewlySet

-- | A 'OnceFlag' which is always 'NewlySet'.
--
-- Only safe to use if the operations to be guarded
-- by the flag are already idempotent.
alwaysNewOnceFlag :: (Applicative m) => OnceFlag m
alwaysNewOnceFlag :: forall (m :: * -> *). Applicative m => OnceFlag m
alwaysNewOnceFlag = forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure FlagState
NewlySet

-- | Hoist a 'OnceFlag' along a given natural transformation into a new monad.
hoistOnceFlag ::
  -- | Natural transformation from @f@ to @g@
  (forall x. f x -> g x) ->
  OnceFlag f ->
  OnceFlag g
hoistOnceFlag :: forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g x) -> OnceFlag f -> OnceFlag g
hoistOnceFlag forall x. f x -> g x
nt (OnceFlag f FlagState
cs) = forall (m :: * -> *). m FlagState -> OnceFlag m
OnceFlag (forall x. f x -> g x
nt f FlagState
cs)