eventuo11y 0.1.0.1 → 0.2.0.0

raw patch · 7 files changed

+402/−282 lines, 7 filesdep +primitivePVP ok

version bump matches the API change (PVP)

Dependencies added: primitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• eventuo11y.cabal +6/−4
• src/Observe/Event.hs +3/−140
• src/Observe/Event/Backend.hs +261/−0
• src/Observe/Event/BackendModification.hs +125/−0
• src/Observe/Event/Implementation.hs +0/−136
• src/Observe/Event/Render/IO/JSON.hs +2/−2

@@ -1,5 +1,10 @@ # Revision history for eventuo11y +## 0.2.0.0 -- 2022-10-03++- Add Observe.Event.BackendModification DSL+- Generalize newOnceFlagIO to newOnceFlagMVar+ ## 0.1.0.1 -- 2022-09-30  Relax aeson lower bound

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               eventuo11y-version:            0.1.0.1+version:            0.2.0.0 synopsis:           An event-oriented observability library description:   Instrument your Haskell codebase with wide, semantically meaningful events.@@ -23,10 +23,10 @@    See "Observe.Event" for detailed documentation on instrumenting your code. -  See "Observe.Event.Implementation" for documentation on writing an+  See "Observe.Event.Backend" for documentation on writing an   @EventBackend@. -  See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.1.0.1/Example.hs) for an example.+  See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.2.0.0/Example.hs) for an example.    See [eventuo11y-batteries](https://hackage.haskell.org/package/eventuo11y-batteries) for miscellaneous   framework-specific helpers.@@ -51,8 +51,9 @@ library   exposed-modules:     Observe.Event+    Observe.Event.Backend+    Observe.Event.BackendModification     Observe.Event.Dynamic-    Observe.Event.Implementation     Observe.Event.Render.IO.JSON     Observe.Event.Render.JSON @@ -61,6 +62,7 @@     , base           >=4.14      && <4.17     , bytestring     >=0.10.12.0 && <0.12     , exceptions     ^>=0.10.4+    , primitive      ^>=0.7     , resourcet      ^>=1.2.4.3     , text           ^>=1.2.5.0     , time           >=1.9.3     && <1.12

@@ -1,7 +1,4 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -82,8 +79,8 @@ import Control.Monad.Catch import Control.Monad.IO.Unlift import Data.Acquire-import Data.Functor-import Observe.Event.Implementation+import Observe.Event.Backend+import Observe.Event.BackendModification  -- | An instrumentation event. --@@ -325,138 +322,4 @@   -- | The parent event.   Event m r s f ->   EventBackend m r s-subEventBackend ev@(Event {..}) =-  EventBackend-    { newEventImpl = \sel -> do-        EventImpl {..} <- newEventImpl backend sel-        parentAdded <- newOnceFlag backend-        pure $-          EventImpl-            { addParentImpl = \r -> do-                _ <- checkAndSet parentAdded-                addParentImpl r,-              finalizeImpl = do-                runOnce parentAdded (addParentImpl $ reference ev)-                finalizeImpl,-              failImpl = \e -> do-                runOnce parentAdded (addParentImpl $ reference ev)-                failImpl e,-              ..-            },-      newOnceFlag = newOnceFlag backend-    }---- | 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 =-  EventBackend-    { newEventImpl = \_ ->-        pure $-          EventImpl-            { referenceImpl = (),-              addFieldImpl = const $ pure (),-              addParentImpl = const $ pure (),-              addProximateImpl = const $ pure (),-              finalizeImpl = pure (),-              failImpl = const $ pure ()-            },-      newOnceFlag = pure alwaysNewOnceFlag-    }---- | An 'EventBackend' which sequentially generates '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 x y =-  EventBackend-    { newEventImpl = \sel -> do-        xImpl <- newEventImpl x sel-        yImpl <- newEventImpl y sel-        pure $-          EventImpl-            { referenceImpl = (referenceImpl xImpl, referenceImpl yImpl),-              addFieldImpl = \f -> addFieldImpl xImpl f *> addFieldImpl yImpl f,-              addParentImpl = \(px, py) -> addParentImpl xImpl px *> addParentImpl yImpl py,-              addProximateImpl = \(px, py) -> addProximateImpl xImpl px *> addProximateImpl yImpl py,-              finalizeImpl = finalizeImpl xImpl *> finalizeImpl yImpl,-              failImpl = \e -> failImpl xImpl e *> failImpl yImpl e-            },-      newOnceFlag = do-        xOnce <- newOnceFlag x-        yOnce <- newOnceFlag y-        pure $-          OnceFlag $ do-            xSet <- checkAndSet xOnce-            ySet <- checkAndSet yOnce-            pure $ case (xSet, ySet) of-              (NewlySet, NewlySet) -> NewlySet-              _ -> 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 nt backend =-  EventBackend-    { newEventImpl = nt . fmap hoistEventImpl . newEventImpl backend,-      newOnceFlag = hoistOnceFlag nt <$> (nt $ newOnceFlag backend)-    }-  where-    hoistEventImpl (EventImpl {..}) =-      EventImpl-        { referenceImpl,-          addFieldImpl = nt . addFieldImpl,-          addParentImpl = nt . addParentImpl,-          addProximateImpl = nt . addProximateImpl,-          finalizeImpl = nt $ finalizeImpl,-          failImpl = nt . 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 inj =-  narrowEventBackend'-    (\sel withInjField -> withInjField (inj sel) 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' inj backend =-  EventBackend-    { newEventImpl = \sel -> inj sel \sel' injField ->-        newEventImpl backend sel' <&> \case-          EventImpl {..} ->-            EventImpl-              { addFieldImpl = addFieldImpl . injField,-                ..-              },-      newOnceFlag = newOnceFlag backend-    }+subEventBackend Event {..} = modifyEventBackend (Cons (SetAncestor $ referenceImpl impl) Nil) backend

@@ -0,0 +1,261 @@+{-# 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,+    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.+    newEventImpl :: !(forall f. s f -> m (EventImpl m r f)),+    -- | Allocate a new 'OnceFlag' in our monad.+    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+  { referenceImpl :: !r,+    addFieldImpl :: !(f -> m ()),+    addParentImpl :: !(r -> m ()),+    addProximateImpl :: !(r -> m ()),+    finalizeImpl :: !(m ()),+    failImpl :: !(Maybe 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 =+  EventBackend+    { newEventImpl = \_ ->+        pure $+          EventImpl+            { referenceImpl = (),+              addFieldImpl = const $ pure (),+              addParentImpl = const $ pure (),+              addProximateImpl = const $ pure (),+              finalizeImpl = pure (),+              failImpl = const $ pure ()+            },+      newOnceFlag = pure alwaysNewOnceFlag+    }++-- | An 'EventBackend' which sequentially generates '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 x y =+  EventBackend+    { newEventImpl = \sel -> do+        xImpl <- newEventImpl x sel+        yImpl <- newEventImpl y sel+        pure $+          EventImpl+            { referenceImpl = (referenceImpl xImpl, referenceImpl yImpl),+              addFieldImpl = \f -> addFieldImpl xImpl f *> addFieldImpl yImpl f,+              addParentImpl = \(px, py) -> addParentImpl xImpl px *> addParentImpl yImpl py,+              addProximateImpl = \(px, py) -> addProximateImpl xImpl px *> addProximateImpl yImpl py,+              finalizeImpl = finalizeImpl xImpl *> finalizeImpl yImpl,+              failImpl = \e -> failImpl xImpl e *> failImpl yImpl e+            },+      newOnceFlag = do+        xOnce <- newOnceFlag x+        yOnce <- newOnceFlag y+        pure $+          OnceFlag $ do+            xSet <- checkAndSet xOnce+            ySet <- checkAndSet yOnce+            pure $ case (xSet, ySet) of+              (NewlySet, NewlySet) -> NewlySet+              _ -> 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 nt backend =+  EventBackend+    { newEventImpl = nt . fmap hoistEventImpl . newEventImpl backend,+      newOnceFlag = hoistOnceFlag nt <$> (nt $ newOnceFlag backend)+    }+  where+    hoistEventImpl (EventImpl {..}) =+      EventImpl+        { referenceImpl,+          addFieldImpl = nt . addFieldImpl,+          addParentImpl = nt . addParentImpl,+          addProximateImpl = nt . addProximateImpl,+          finalizeImpl = nt $ finalizeImpl,+          failImpl = nt . 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 inj =+  narrowEventBackend'+    (\sel withInjField -> withInjField (inj sel) 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' inj backend =+  EventBackend+    { newEventImpl = \sel -> inj sel \sel' injField ->+        newEventImpl backend sel' <&> \case+          EventImpl {..} ->+            EventImpl+              { addFieldImpl = addFieldImpl . injField,+                ..+              },+      newOnceFlag = newOnceFlag 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).+    checkAndSet :: m FlagState+  }++-- | Run an operation if no other operations using this+-- 'OnceFlag' have run.+runOnce :: (Monad m) => OnceFlag m -> m () -> m ()+runOnce f go =+  checkAndSet f >>= \case+    NewlySet -> go+    AlreadySet -> pure ()++-- | A 'OnceFlag' using an 'MVar'.+newOnceFlagMVar :: (PrimMonad m) => m (OnceFlag m)+newOnceFlagMVar = do+  flag <- newEmptyMVar+  pure $+    OnceFlag $+      tryPutMVar flag () <&> \case+        False -> AlreadySet+        True -> 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 = OnceFlag $ pure 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 nt (OnceFlag cs) = OnceFlag (nt cs)

@@ -0,0 +1,125 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Description : Domain-specific language for modifying the behavior of EventBackends+-- Copyright   : Copyright 2022 Shea Levy.+-- License     : Apache-2.0+-- Maintainer  : shea@shealevy.com+--+-- A domain-specific language for modifying the behavior of t'Observe.Event.EventBackend's, needed when+-- the caller can't specify the t'Observe.Event.EventBackend' to use directly.+--+-- = The instrumented capability problem+--+-- A common approach for polymorphic effect management in Haskell is the "capability pattern",+-- where a function polymorphic in some monad @m@ takes as an argument a value also polymorphic+-- in @m@ that can be used to run a constrained set of effects in @m@. One example of such a+-- "capability" type would be t'Observe.Event.EventBackend', which for example enables running+-- 'Observe.Event.newEvent' in whatever @m@ it's instantiated in. These capabilities are often+-- themselves implemented in terms of other capabilities, and are ultimately concretely+-- instantiated in some base monad (typically `IO`, or perhaps t`Control.Monad.ST.ST` for a pure+-- mock) and then @hoist@ed to the application's monadic context (e.g. 'Observe.Event.hoistEventBackend').+--+-- Normally this compose + hoist approach works fine, since any capabilities that are dependencies of the+-- the capability we're hoisting are hidden in its closure. But if a capability depends on an `EventBackend`+-- for instrumentation, closing over it at creation time causes a problem: at the call-site of the various+-- effects enabled by the capability, we have no way to modify the t'Observe.Event.EventBackend' to e.g. be a noop (because+-- we don't need the details of this effect's actions to instrument the calling function effectively) or to+-- have its t'Observe.Event.Event's descend from some current 'Observe.Event.Event'. Thus, the DSL defined+-- in this module: effects which take some polymorphic capability can *also* take an 'EventBackendModifier'+-- and the capability can modify its captured t'Observe.Event.EventBackend' with 'modifyEventBackend' accordingly.+--+-- An alternative would be to have each effect in the capability take an t'Observe.Event.EventBackend' at the call site.+-- This would foreclose @hoist@ing along an arbitrary natural transformation, since the t'Observe.Event.EventBackend' would+-- be in negative position, but constrained @hoist@ing might be possible with @MonadUnliftIO@ or @MonadUnlift@+-- or @MonadBaseControl@ if we share a base monad, or if we implemented t'Observe.Event.EventBackend's in a separate base monad+-- that appears in the type of our capabilities and ensure it's liftable to both our application monad and the+-- capability's base instantiation.+module Observe.Event.BackendModification where++import Control.Category+import Observe.Event.Backend+import Prelude hiding ((.))++-- | Modify an t'Observe.Event.EventBackend', chaging its reference type from @r@ to @r'@+data EventBackendModifier r r' where+  -- | Ignore all instrumentation using the t'Observe.Event.EventBackend'+  Silence :: forall r. EventBackendModifier r ()+  -- | Mark every parentless event as the child of a known t'Observe.Event.Event'.+  SetAncestor ::+    forall r.+    -- | A 'Observe.Event.reference' to the parent t'Observe.Event.Event'.+    r ->+    EventBackendModifier r r+  -- | Mark every causeless event as proximately caused by a known t'Observe.Event.Event'.+  SetInitialCause ::+    forall r.+    -- | A 'Observe.Event.reference' to the causing t'Observe.Event.Event'.+    r ->+    EventBackendModifier r r++-- | A sequence of 'EventBackendModifier's+--+-- The free 'Category' over 'EventBackendModifier'+data EventBackendModifiers r r' where+  Nil :: forall r. EventBackendModifiers r r+  Cons :: forall r r' r''. EventBackendModifier r' r'' -> EventBackendModifiers r r' -> EventBackendModifiers r r''++instance Category EventBackendModifiers where+  id = Nil+  Nil . f = f+  (Cons hd tl) . f = Cons hd (tl . f)++-- | Modify an t'Observe.Event.EventBackend' according to the given 'EventBackendModifiers'.+--+-- This is a right fold, e.g. @modifyEventBackend (a . b . id) backend@ first+-- modifies @backend@ with @b@ and then modifies the result with @a@.+modifyEventBackend :: Monad m => EventBackendModifiers r r' -> EventBackend m r s -> EventBackend m r' s+modifyEventBackend Nil backend = backend+modifyEventBackend (Cons Silence _) _ = unitEventBackend+modifyEventBackend (Cons (SetAncestor parent) rest) backend' =+  EventBackend+    { newEventImpl = \sel -> do+        EventImpl {..} <- newEventImpl backend sel+        parentAdded <- newOnceFlag backend+        pure $+          EventImpl+            { addParentImpl = \r -> do+                _ <- checkAndSet parentAdded+                addParentImpl r,+              finalizeImpl = do+                runOnce parentAdded (addParentImpl parent)+                finalizeImpl,+              failImpl = \e -> do+                runOnce parentAdded (addParentImpl parent)+                failImpl e,+              ..+            },+      newOnceFlag = newOnceFlag backend+    }+  where+    backend = modifyEventBackend rest backend'+modifyEventBackend (Cons (SetInitialCause proximate) rest) backend' =+  EventBackend+    { newEventImpl = \sel -> do+        EventImpl {..} <- newEventImpl backend sel+        proximateAdded <- newOnceFlag backend+        pure $+          EventImpl+            { addProximateImpl = \r -> do+                _ <- checkAndSet proximateAdded+                addParentImpl r,+              finalizeImpl = do+                runOnce proximateAdded (addProximateImpl proximate)+                finalizeImpl,+              failImpl = \e -> do+                runOnce proximateAdded (addProximateImpl proximate)+                failImpl e,+              ..+            },+      newOnceFlag = newOnceFlag backend+    }+  where+    backend = modifyEventBackend rest backend'

@@ -1,136 +0,0 @@-{-# 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.Implementation-  ( EventBackend (..),-    EventImpl (..),--    -- * OnceFlags--    -- | Generic helper to make operations idempotent.-    OnceFlag (..),-    FlagState (..),-    runOnce,-    hoistOnceFlag,-    alwaysNewOnceFlag,-    newOnceFlagIO,-  )-where--import Control.Concurrent.MVar-import Control.Exception-import Data.Functor---- | 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.-    newEventImpl :: !(forall f. s f -> m (EventImpl m r f)),-    -- | Allocate a new 'OnceFlag' in our monad.-    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-  { referenceImpl :: !r,-    addFieldImpl :: !(f -> m ()),-    addParentImpl :: !(r -> m ()),-    addProximateImpl :: !(r -> m ()),-    finalizeImpl :: !(m ()),-    failImpl :: !(Maybe SomeException -> m ())-  }---- | 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).-    checkAndSet :: m FlagState-  }---- | Run an operation if no other operations using this--- 'OnceFlag' have run.-runOnce :: (Monad m) => OnceFlag m -> m () -> m ()-runOnce f go =-  checkAndSet f >>= \case-    NewlySet -> go-    AlreadySet -> pure ()---- | A 'OnceFlag' in 'IO' using an 'MVar'.-newOnceFlagIO :: IO (OnceFlag IO)-newOnceFlagIO = do-  flag <- newEmptyMVar-  pure $-    OnceFlag $-      tryPutMVar flag () <&> \case-        False -> AlreadySet-        True -> 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 = OnceFlag $ pure 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 nt (OnceFlag cs) = OnceFlag (nt cs)

@@ -29,7 +29,7 @@ import Data.UUID (UUID) import Data.UUID.V4 import Observe.Event-import Observe.Event.Implementation+import Observe.Event.Backend import Observe.Event.Render.JSON import System.IO (Handle, stderr) @@ -112,7 +112,7 @@                           Nothing -> UnstructuredFail e                     )               },-        newOnceFlag = newOnceFlagIO+        newOnceFlag = newOnceFlagMVar       }  -- | An 'EventBackend' which posts events to @stderr@ as JSON.