eventuo11y 0.4.0.0 → 0.5.0.0

raw patch · 9 files changed

+488/−409 lines, 9 filesdep +safe-exceptionsdep +transformersdep −aesondep −bytestringdep −textdep ~basedep ~resourcetPVP ok

version bump matches the API change (PVP)

Dependencies added: safe-exceptions, transformers

Dependencies removed: aeson, bytestring, text, time, uuid

Dependency ranges changed: base, resourcet

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−2
• Example.hs +53/−65
• eventuo11y.cabal +17/−17
• src/Control/Monad/Cleanup.hs +296/−0
• src/Observe/Event.hs +94/−20
• src/Observe/Event/Backend.hs +16/−13
• src/Observe/Event/Dynamic.hs +0/−61
• src/Observe/Event/Render/IO/JSON.hs +0/−140
• src/Observe/Event/Render/JSON.hs +0/−91

@@ -1,8 +1,18 @@ # Revision history for eventuo11y -## 0.4.0.0 -- 2022-10-04+## 0.5.0.0 -- 2022-10-23 -Have SomeJSONException take a RenderExJSON directly+- Add MonadCleanup+- Break out eventuo11y-json+- Include narrowing in subEventBackend and causedEventBackend++## 0.3.2.0 -- 2022-10-04++Add hoistEvent++## 0.3.1.0 -- 2022-10-04++Add causedEventBackend  ## 0.3.0.0 -- 2022-10-03 

@@ -2,8 +2,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-}  module Main where@@ -19,8 +21,10 @@ import Foreign.Ptr import GHC.Generics import Observe.Event-import Observe.Event.Render.IO.JSON+import Observe.Event.DSL import Observe.Event.Render.JSON+import Observe.Event.Render.JSON.DSL.Compile+import Observe.Event.Render.JSON.Handle import System.FilePath import System.IO.Temp import System.Posix.Files@@ -29,6 +33,42 @@  -- Pretend this is in a separate module File where +deriving instance Show Errno++deriving instance ToJSON Errno++deriving instance Generic Errno++deriving instance ToJSON CInt++deriving instance Generic CInt++deriving instance ToJSON Fd++deriving instance Generic Fd++deriving instance ToJSON ByteCount++deriving instance Generic ByteCount++-- Define our selector type and give it instances to render as JSON+compile $+  SelectorSpec+    "file" -- Creates a type FileSelector+    [ ["open", "file"] -- Creates a constructor OpenFile :: FileSelector OpenField+        ≔ FieldSpec+          "open" -- Creates a type OpenField+          [ "filename" ≔ ''FilePath, -- creates a constructor Filename :: !FilePath -> OpenField+            ["file", "fd"] ≔ ''Fd -- creates a constructor FileFd :: !Fd -> OpenField+          ],+      "write"+        ≔ FieldSpec+          "write"+          [ ["bytes", "asked"] ≔ ''ByteCount,+            ["bytes", "actual"] ≔ ''ByteCount+          ]+    ]+ -- We take an EventBackend, polymorphic in r, supporting our domain-specific selector type writeToFile :: EventBackend IO r FileSelector -> FilePath -> ByteString -> IO () writeToFile backend path bs = do@@ -50,7 +90,7 @@     let bcSz = fromIntegral sz         go :: ByteCount -> IO ()         go offset = do-          newOffset <- withEvent backend WriteFile $ \ev -> do+          newOffset <- withEvent backend Write $ \ev -> do             let ct = bcSz - offset             addField ev $ BytesAsked ct             written <- fdWriteBuf fd (plusPtr ptr (base_off + fromIntegral offset)) ct@@ -62,34 +102,6 @@   closeFd fd   pure () --- Define our selector type. A GADT, parameterized by field type-data FileSelector f where-  OpenFile :: FileSelector OpenField-  WriteFile :: FileSelector WriteField---- Define a renderer for our selector type-renderFileSelector :: RenderSelectorJSON FileSelector-renderFileSelector OpenFile = ("open-file", renderOpenField) -- Expressed in terms of renderers for our field tyeps-renderFileSelector WriteFile = ("write-file", renderWriteField)---- Define a field type-data OpenField-  = Filename !FilePath-  | FileFd !Fd---- Define a renderer for a field type-renderOpenField :: RenderFieldJSON OpenField-renderOpenField (Filename path) = ("file-name", toJSON path)-renderOpenField (FileFd fd) = ("file-fd", toJSON fd)--data WriteField-  = BytesAsked !ByteCount-  | BytesActual !ByteCount--renderWriteField :: RenderFieldJSON WriteField-renderWriteField (BytesAsked ct) = ("asked", toJSON ct)-renderWriteField (BytesActual ct) = ("actual", toJSON ct)- -- Define a new exception that can be used with simpleJsonStderrBackend data BadOpen = BadOpen   { path :: !FilePath,@@ -99,52 +111,28 @@  -- Our exception is beneath SomeJSONException in the hierarchy instance Exception BadOpen where-  toException = jsonExceptionToException toJSON+  toException = jsonExceptionToException   fromException = jsonExceptionFromException  -- end module File +compile $+  SelectorSpec+    "main"+    [ ["using", "temp", "dir"] ≔ ''FilePath, -- Creates a constructor UsingTempDir :: MainSelector FilePath+      "writing" ≔ Inject ''FileSelector -- Creates a constructor Writing :: FileSelector x -> MainSelector x+    ]+ -- Note a different selector type than writeToFile instrumentedMain :: EventBackend IO r MainSelector -> IO () instrumentedMain backend = do   withEvent backend UsingTempDir $ \ev -> do     withSystemTempDirectory "example" $ \dir -> do       addField ev dir-      let -- Create a new EventBackend where all parentless events are made children of our current event-          subBackend = subEventBackend ev-          -- Narrow subBackend to create events from FileSelectors instead of MainSelectors-          narrowerBackend = narrowEventBackend InjectFileSelector subBackend-      -- Pass our narrower backend to writeToFile-      writeToFile narrowerBackend (dir </> "example.txt") "example"+      -- Pass a new EventBackend where all parentless events are made children of our current event+      writeToFile (subEventBackend Writing ev) (dir </> "example.txt") "example"  main :: IO () main =   -- Initialize a backend to write JSON to stderr and use it.-  simpleJsonStderrBackend renderMainSelector >>= instrumentedMain---- Instrumentation definitions-data MainSelector f where-  UsingTempDir :: MainSelector FilePath-  InjectFileSelector :: FileSelector a -> MainSelector a -- A typical pattern together with narrowEventBackend to call functions with a more specialized selector type--renderMainSelector :: RenderSelectorJSON MainSelector-renderMainSelector UsingTempDir = ("using-tmp-dir", \f -> ("path", toJSON f))-renderMainSelector (InjectFileSelector filesel) = renderFileSelector filesel -- Note that we reuse the selector renderer from our File "module"--deriving instance Show Errno--deriving instance ToJSON Errno--deriving instance Generic Errno--deriving instance ToJSON CInt--deriving instance Generic CInt--deriving instance ToJSON Fd--deriving instance Generic Fd--deriving instance ToJSON ByteCount--deriving instance Generic ByteCount+  simpleJsonStderrBackend defaultRenderSelectorJSON >>= instrumentedMain

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               eventuo11y-version:            0.4.0.0+version:            0.5.0.0 synopsis:           An event-oriented observability library description:   Instrument your Haskell codebase with wide, semantically meaningful events.@@ -26,8 +26,14 @@   See "Observe.Event.Backend" for documentation on writing an   @EventBackend@. -  See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.4.0.0/Example.hs) for an example.+  See [eventuo11y-dsl](https://hackage.haskell.org/package/eventuo11y-dsl) for simpler syntax for+  creating application-level instrumentation types. +  See [eventuo11y-json](https://hackage.haskell.org/package/eventuo11y-json) for JSON-based rendering+  and backends.++  See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.5.0.0/Example.hs) for an example.+   See [eventuo11y-batteries](https://hackage.haskell.org/package/eventuo11y-batteries) for miscellaneous   framework-specific helpers. @@ -41,8 +47,7 @@ extra-source-files:   CHANGELOG.md   Example.hs--tested-with:        GHC ==8.10.7 || ==9.0.2 || ==9.2.2+tested-with:        GHC == { 8.10.7, 9.2.4 }  source-repository head   type:     git@@ -50,24 +55,19 @@  library   exposed-modules:+    Control.Monad.Cleanup     Observe.Event     Observe.Event.Backend     Observe.Event.BackendModification-    Observe.Event.Dynamic-    Observe.Event.Render.IO.JSON-    Observe.Event.Render.JSON    build-depends:-    , aeson          ^>=2.0-    , base           >=4.14    && <4.17-    , bytestring     >=0.10    && <0.12-    , exceptions     ^>=0.10-    , primitive      ^>=0.7-    , resourcet      ^>=1.2-    , text           >=1.2     && <2.1-    , time           >=1.9     && <1.12-    , unliftio-core  ^>=0.2-    , uuid           ^>=1.3+    , base             ^>= { 4.14, 4.16 }+    , exceptions       ^>= 0.10+    , primitive        ^>= 0.7+    , resourcet        ^>= { 1.2, 1.3 }+    , safe-exceptions  ^>= 0.1+    , transformers     ^>= 0.5+    , unliftio-core    ^>= 0.2    hs-source-dirs:   src   default-language: Haskell2010

@@ -0,0 +1,296 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Description : Monads that can cleanup within a single monaadic scope+-- Copyright   : Copyright 2022 Shea Levy.+-- License     : Apache-2.0+-- Maintainer  : shea@shealevy.com+module Control.Monad.Cleanup where++import Control.Exception.Safe+import Control.Monad.Catch (ExitCase (..))+import Control.Monad.ST+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS+import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)+import qualified Control.Monad.Trans.State.Lazy as LazyS+import qualified Control.Monad.Trans.State.Strict as StrictS+import qualified Control.Monad.Trans.Writer.Lazy as LazyW+import qualified Control.Monad.Trans.Writer.Strict as StrictW+import Data.Coerce+import Data.Functor.Identity++-- | Monads that can cleanup within a single monadic scope.+--+-- 'MonadCleanup's allow for acquiring some resource and+-- guaranteeing that it will be released,+-- __if computation might continue within that monad__.+--+-- This is very similar to 'MonadMask', with the following differences:+--+-- 1. 'MonadCleanup's may not be able to throw or catch exceptions (no 'MonadCatch'+--    superclass) or mask exceptions.+-- 2. The guarantee of 'generalCleanup' is not as absolute as 'generalBracket' (though the latter+--    always has the @SIGKILL@/power goes out exception). If we can't handle exceptions+--    at all in the monad (at least not without @unsafePerformIO@), then sometimes the cleanup+--    function won't be called, but only in cases where the entire computation the monad is+--    running is going to be aborted.+--+-- This allows 'MonadCleanup' to be used in pure contexts (see 'CleanupNoException') and still+-- provide meaningful semantics.+class (Monad m) => MonadCleanup m where+  -- | Acquire some resource, use it, and clean it up.+  --+  -- cleanup is guaranteed to run+  -- __if computation in the surrounding monadic scope might continue__.+  --+  -- Similar to 'generalBracket', see documentation of 'MonadCleanup' for the differences.+  generalCleanup ::+    -- | Acquire some resource+    m a ->+    -- | Release the resource, observing the outcome of the inner action+    (a -> ExitCase b -> m c) ->+    -- | Inner action to perform with the resource+    (a -> m b) ->+    m (b, c)++-- | An 'Exception' corresponding to the 'ExitCaseAbort' exit case.+data AbortException = AbortException+  deriving stock (Show)+  deriving anyclass (Exception)++-- | Acquire some resource, use it, and clean it up.+--+-- This is to 'bracketWithError' as 'generalCleanup' is to 'generalBracket', see documentation+-- of 'generalCleanup' for more details.+withCleanup ::+  (MonadCleanup m) =>+  m a ->+  (Maybe SomeException -> a -> m b) ->+  (a -> m c) ->+  m c+withCleanup acquire cleanup go = fst <$> generalCleanup acquire release go+  where+    release x (ExitCaseSuccess _) = cleanup Nothing x+    release x ExitCaseAbort = cleanup (Just (toException AbortException)) x+    release x (ExitCaseException e) = cleanup (Just e) x++-- | A [DerivingVia](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html) helper for deriving 'MonadCleanup' from 'MonadMask'.+newtype CleanupFromMask m a = CleanupFromMask (m a) deriving newtype (Functor, Applicative, Monad)++instance (MonadMask m) => MonadCleanup (CleanupFromMask m) where+  generalCleanup :: forall a b c. CleanupFromMask m a -> (a -> ExitCase b -> CleanupFromMask m c) -> (a -> CleanupFromMask m b) -> CleanupFromMask m (b, c)+  generalCleanup = coerce $ generalBracket @m @a @b @c++deriving via CleanupFromMask IO instance MonadCleanup IO++-- | A [DerivingVia](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html) for deriving 'MonadCleanup' in a 'Monad' which+-- __can't__ handle exceptions.+--+-- If cleanup runs at all, it will run in 'ExitCaseSuccess'+--+-- __Note that the associated 'MonadCleanup' instance is invalid if it is possible to catch exceptions in the monad!__+newtype CleanupNoException m a = CleanupNoException (m a) deriving newtype (Functor, Applicative, Monad)++instance (Monad m) => MonadCleanup (CleanupNoException m) where+  generalCleanup acquire release go = do+    x <- acquire+    res <- go x+    carry <- release x (ExitCaseSuccess res)+    pure (res, carry)++deriving via CleanupNoException (ST s) instance MonadCleanup (ST s)++deriving via CleanupNoException Identity instance MonadCleanup Identity++instance (MonadCleanup m) => MonadCleanup (IdentityT m) where+  generalCleanup acquire release use =+    IdentityT $+      generalCleanup+        (runIdentityT acquire)+        (\resource exitCase -> runIdentityT (release resource exitCase))+        (\resource -> runIdentityT (use resource))++instance MonadCleanup m => MonadCleanup (LazyS.StateT s m) where+  generalCleanup acquire release use = LazyS.StateT $ \s0 -> do+    ((b, _s2), (c, s3)) <-+      generalCleanup+        (LazyS.runStateT acquire s0)+        ( \(resource, s1) exitCase -> case exitCase of+            ExitCaseSuccess (b, s2) -> LazyS.runStateT (release resource (ExitCaseSuccess b)) s2+            -- In the two other cases, the base monad overrides @use@'s state+            -- changes and the state reverts to @s1@.+            ExitCaseException e -> LazyS.runStateT (release resource (ExitCaseException e)) s1+            ExitCaseAbort -> LazyS.runStateT (release resource ExitCaseAbort) s1+        )+        (\(resource, s1) -> LazyS.runStateT (use resource) s1)+    return ((b, c), s3)++instance MonadCleanup m => MonadCleanup (StrictS.StateT s m) where+  generalCleanup acquire release use = StrictS.StateT $ \s0 -> do+    ((b, _s2), (c, s3)) <-+      generalCleanup+        (StrictS.runStateT acquire s0)+        ( \(resource, s1) exitCase -> case exitCase of+            ExitCaseSuccess (b, s2) -> StrictS.runStateT (release resource (ExitCaseSuccess b)) s2+            -- In the two other cases, the base monad overrides @use@'s state+            -- changes and the state reverts to @s1@.+            ExitCaseException e -> StrictS.runStateT (release resource (ExitCaseException e)) s1+            ExitCaseAbort -> StrictS.runStateT (release resource ExitCaseAbort) s1+        )+        (\(resource, s1) -> StrictS.runStateT (use resource) s1)+    return ((b, c), s3)++instance MonadCleanup m => MonadCleanup (ReaderT r m) where+  generalCleanup acquire release use = ReaderT $ \r ->+    generalCleanup+      (runReaderT acquire r)+      (\resource exitCase -> runReaderT (release resource exitCase) r)+      (\resource -> runReaderT (use resource) r)++instance (MonadCleanup m, Monoid w) => MonadCleanup (StrictW.WriterT w m) where+  generalCleanup acquire release use = StrictW.WriterT $ do+    ((b, _w12), (c, w123)) <-+      generalCleanup+        (StrictW.runWriterT acquire)+        ( \(resource, w1) exitCase -> case exitCase of+            ExitCaseSuccess (b, w12) -> do+              (c, w3) <- StrictW.runWriterT (release resource (ExitCaseSuccess b))+              return (c, mappend w12 w3)+            -- In the two other cases, the base monad overrides @use@'s state+            -- changes and the state reverts to @w1@.+            ExitCaseException e -> do+              (c, w3) <- StrictW.runWriterT (release resource (ExitCaseException e))+              return (c, mappend w1 w3)+            ExitCaseAbort -> do+              (c, w3) <- StrictW.runWriterT (release resource ExitCaseAbort)+              return (c, mappend w1 w3)+        )+        ( \(resource, w1) -> do+            (a, w2) <- StrictW.runWriterT (use resource)+            return (a, mappend w1 w2)+        )+    return ((b, c), w123)++instance (MonadCleanup m, Monoid w) => MonadCleanup (LazyW.WriterT w m) where+  generalCleanup acquire release use = LazyW.WriterT $ do+    ((b, _w12), (c, w123)) <-+      generalCleanup+        (LazyW.runWriterT acquire)+        ( \(resource, w1) exitCase -> case exitCase of+            ExitCaseSuccess (b, w12) -> do+              (c, w3) <- LazyW.runWriterT (release resource (ExitCaseSuccess b))+              return (c, mappend w12 w3)+            -- In the two other cases, the base monad overrides @use@'s state+            -- changes and the state reverts to @w1@.+            ExitCaseException e -> do+              (c, w3) <- LazyW.runWriterT (release resource (ExitCaseException e))+              return (c, mappend w1 w3)+            ExitCaseAbort -> do+              (c, w3) <- LazyW.runWriterT (release resource ExitCaseAbort)+              return (c, mappend w1 w3)+        )+        ( \(resource, w1) -> do+            (a, w2) <- LazyW.runWriterT (use resource)+            return (a, mappend w1 w2)+        )+    return ((b, c), w123)++instance (MonadCleanup m, Monoid w) => MonadCleanup (LazyRWS.RWST r w s m) where+  generalCleanup acquire release use = LazyRWS.RWST $ \r s0 -> do+    ((b, _s2, _w12), (c, s3, w123)) <-+      generalCleanup+        (LazyRWS.runRWST acquire r s0)+        ( \(resource, s1, w1) exitCase -> case exitCase of+            ExitCaseSuccess (b, s2, w12) -> do+              (c, s3, w3) <- LazyRWS.runRWST (release resource (ExitCaseSuccess b)) r s2+              return (c, s3, mappend w12 w3)+            -- In the two other cases, the base monad overrides @use@'s state+            -- changes and the state reverts to @s1@ and @w1@.+            ExitCaseException e -> do+              (c, s3, w3) <- LazyRWS.runRWST (release resource (ExitCaseException e)) r s1+              return (c, s3, mappend w1 w3)+            ExitCaseAbort -> do+              (c, s3, w3) <- LazyRWS.runRWST (release resource ExitCaseAbort) r s1+              return (c, s3, mappend w1 w3)+        )+        ( \(resource, s1, w1) -> do+            (a, s2, w2) <- LazyRWS.runRWST (use resource) r s1+            return (a, s2, mappend w1 w2)+        )+    return ((b, c), s3, w123)++instance (MonadCleanup m, Monoid w) => MonadCleanup (StrictRWS.RWST r w s m) where+  generalCleanup acquire release use = StrictRWS.RWST $ \r s0 -> do+    ((b, _s2, _w12), (c, s3, w123)) <-+      generalCleanup+        (StrictRWS.runRWST acquire r s0)+        ( \(resource, s1, w1) exitCase -> case exitCase of+            ExitCaseSuccess (b, s2, w12) -> do+              (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseSuccess b)) r s2+              return (c, s3, mappend w12 w3)+            -- In the two other cases, the base monad overrides @use@'s state+            -- changes and the state reverts to @s1@ and @w1@.+            ExitCaseException e -> do+              (c, s3, w3) <- StrictRWS.runRWST (release resource (ExitCaseException e)) r s1+              return (c, s3, mappend w1 w3)+            ExitCaseAbort -> do+              (c, s3, w3) <- StrictRWS.runRWST (release resource ExitCaseAbort) r s1+              return (c, s3, mappend w1 w3)+        )+        ( \(resource, s1, w1) -> do+            (a, s2, w2) <- StrictRWS.runRWST (use resource) r s1+            return (a, s2, mappend w1 w2)+        )+    return ((b, c), s3, w123)++instance MonadCleanup m => MonadCleanup (MaybeT m) where+  generalCleanup acquire release use = MaybeT $ do+    (eb, ec) <-+      generalCleanup+        (runMaybeT acquire)+        ( \resourceMay exitCase -> case resourceMay of+            Nothing -> return Nothing -- nothing to release, acquire didn't succeed+            Just resource -> case exitCase of+              ExitCaseSuccess (Just b) -> runMaybeT (release resource (ExitCaseSuccess b))+              ExitCaseException e -> runMaybeT (release resource (ExitCaseException e))+              _ -> runMaybeT (release resource ExitCaseAbort)+        )+        ( \resourceMay -> case resourceMay of+            Nothing -> return Nothing+            Just resource -> runMaybeT (use resource)+        )+    -- The order in which we perform those two 'Maybe' effects doesn't matter,+    -- since the error message is the same regardless.+    return ((,) <$> eb <*> ec)++instance MonadCleanup m => MonadCleanup (ExceptT e m) where+  generalCleanup acquire release use = ExceptT $ do+    (eb, ec) <-+      generalCleanup+        (runExceptT acquire)+        ( \eresource exitCase -> case eresource of+            Left e -> return (Left e) -- nothing to release, acquire didn't succeed+            Right resource -> case exitCase of+              ExitCaseSuccess (Right b) -> runExceptT (release resource (ExitCaseSuccess b))+              ExitCaseException e -> runExceptT (release resource (ExitCaseException e))+              _ -> runExceptT (release resource ExitCaseAbort)+        )+        (either (return . Left) (runExceptT . use))+    return $ do+      -- The order in which we perform those two 'Either' effects determines+      -- which error will win if they are both 'Left's. We want the error from+      -- 'release' to win.+      c <- ec+      b <- eb+      return (b, c)

@@ -1,7 +1,10 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE CPP #-} -- | -- Description : Core interface for instrumentation with eventuo11y -- Copyright   : Copyright 2022 Shea Levy.@@ -40,6 +43,7 @@ --  t'Observe.Event.Render.JSON.RenderFieldJSON' to use JSON rendering 'EventBackend's. module Observe.Event   ( Event,+    hoistEvent,      -- * Event manipulation #eventmanip#     reference,@@ -51,6 +55,10 @@     withEvent,     withSubEvent, +    -- ** MonadMask variants+    withEventMask,+    withSubEventMask,+     -- ** Acquire/MonadResource variants     acquireEvent,     acquireSubEvent,@@ -58,6 +66,7 @@     -- * 'EventBackend's     EventBackend,     subEventBackend,+    causedEventBackend,     unitEventBackend,     pairEventBackend,     hoistEventBackend,@@ -75,8 +84,8 @@   ) where -import Control.Exception-import Control.Monad.Catch+import Control.Exception.Safe+import Control.Monad.Cleanup import Control.Monad.IO.Unlift import Data.Acquire import Observe.Event.Backend@@ -104,6 +113,15 @@     finishFlag :: !(OnceFlag m)   } +-- | Hoist an 'Event' along a given natural transformation into a new monad.+hoistEvent :: (Functor m, Functor n) => (forall x. m x -> n x) -> Event m r s f -> Event n r s f+hoistEvent nt Event {..} =+  Event+    { backend = hoistEventBackend nt backend,+      impl = hoistEventImpl nt impl,+      finishFlag = hoistOnceFlag nt finishFlag+    }+ -- | Obtain a reference to an 'Event'. -- -- References are used to link 'Event's together, either in@@ -166,7 +184,7 @@ finalize :: (Monad m) => Event m r s f -> m () finalize (Event {..}) = runOnce finishFlag $ finalizeImpl impl --- | Mark an 'Event' as having failed, possibly due to an 'Exception'.+-- | Mark an 'Event' as having failed due to an 'Exception'. -- -- In normal usage, this should be automatically called via the use of -- the [resource-safe event allocation functions](#g:resourcesafe).@@ -175,7 +193,7 @@ -- 'failEvent'ed. As a result, it is likely pointless to call -- 'addField', 'addParent', or 'addProximate' after this call, -- though it still may be reasonable to call 'reference'.-failEvent :: (Monad m) => Event m r s f -> Maybe SomeException -> m ()+failEvent :: (Monad m) => Event m r s f -> SomeException -> m () failEvent (Event {..}) = runOnce finishFlag . failImpl impl  -- | Create a new 'Event', selected by the given selector.@@ -237,20 +255,17 @@ -- The 'Event' is automatically 'finalize'd (or, if appropriate, 'failEvent'ed) -- at the end of the function it's passed to. withEvent ::-  (MonadMask m) =>+  (MonadCleanup m) =>   EventBackend m r s ->   forall f.   -- | The event selector.   s f ->   (Event m r s f -> m a) ->   m a-withEvent backend sel go = do-  (res, ()) <- generalBracket (newEvent backend sel) release go-  pure res+withEvent backend sel go = withCleanup (newEvent backend sel) cleanup go   where-    release ev (ExitCaseSuccess _) = finalize ev-    release ev (ExitCaseException e) = failEvent ev $ Just e-    release ev ExitCaseAbort = failEvent ev Nothing+    cleanup Nothing = finalize+    cleanup (Just e) = flip failEvent e  -- | Run an action with a new 'Event' as a child of the given 'Event', selected by the given selector. --@@ -264,7 +279,7 @@ -- The 'Event' is automatically 'finalize'd (or, if appropriate, 'failEvent'ed) -- at the end of the function it's passed to. withSubEvent ::-  (MonadMask m) =>+  (MonadCleanup m) =>   -- | The parent 'Event'.   Event m r s f ->   forall f'.@@ -276,10 +291,43 @@   addParent child $ referenceImpl impl   go child +-- TODO Implement in terms of withEvent + CleanupFromMask++-- | 'withEvent' in 'MonadMask'+withEventMask ::+  forall m r s.+  (MonadMask m) =>+  EventBackend m r s ->+  forall f.+  -- | The event selector.+  s f ->+  forall a.+  (Event m r s f -> m a) ->+  m a+withEventMask backend sel go = bracketWithError (newEvent backend sel) release go+  where+    release Nothing = finalize+    release (Just e) = flip failEvent e++-- TODO implement in terms of withSubEvent + CleanupFromMask++-- | 'withSubEvent' in 'MonadMask'+withSubEventMask ::+  (MonadMask m) =>+  -- | The parent 'Event'.+  Event m r s f ->+  forall f'.+  -- | The child event selector.+  s f' ->+  (Event m r s f' -> m a) ->+  m a+withSubEventMask (Event {..}) sel go = withEventMask backend sel $ \child -> do+  addParent child $ referenceImpl impl+  go child+ -- | An 'Acquire' variant of 'withEvent', usable in a t'Control.Monad.Trans.Resource.MonadResource' with 'allocateAcquire'. ----- Until [snoyberg/conduit#460](https://github.com/snoyberg/conduit/issues/460) is addressed, exception--- information will not be captured.+-- Prior to @resourcet@ version @1.3.0@, exceptional exit will 'failEvent' with 'AbortException'. acquireEvent ::   (MonadUnliftIO m) =>   EventBackend m r s ->@@ -293,13 +341,16 @@       (runInIO $ newEvent backend sel)       (release runInIO)   where-    release runInIO ev ReleaseException = runInIO $ failEvent ev Nothing+#if MIN_VERSION_resourcet(1,3,0)+    release runInIO ev (ReleaseExceptionWith e) = runInIO $ failEvent ev e+#else+    release runInIO ev ReleaseException = runInIO . failEvent ev $ toException AbortException+#endif     release runInIO ev _ = runInIO $ finalize ev  -- | An 'Acquire' variant of 'withSubEvent', usable in a t'Control.Monad.Trans.Resource.MonadResource' with 'allocateAcquire'. ----- Until [snoyberg/conduit#460](https://github.com/snoyberg/conduit/issues/460) is addressed, exception--- information will not be captured.+-- Prior to @resourcet@ version @1.3.0@, exceptional exit will 'failEvent' with 'AbortException'. acquireSubEvent ::   (MonadUnliftIO m) =>   -- | The parent event.@@ -319,7 +370,30 @@ -- as a child of the given 'Event'. subEventBackend ::   (Monad m) =>+  -- | Bring selectors from the new backend into the parent event's backend.+  --+  -- Use 'id' here plus 'narrowEventBackend'' if you need a more general mapping+  -- between selector types.+  (forall f'. s f' -> t f') ->   -- | The parent event.-  Event m r s f ->+  Event m r t f ->   EventBackend m r s-subEventBackend Event {..} = modifyEventBackend (setAncestor $ referenceImpl impl) backend+subEventBackend inj Event {..} =+  narrowEventBackend inj $+    modifyEventBackend (setAncestor $ referenceImpl impl) backend++-- | An 'EventBackend' where every otherwise causeless event will be marked+-- as caused by the given 'Event'.+causedEventBackend ::+  (Monad m) =>+  -- | Bring selectors from the new backend into the causing event's backend.+  --+  -- Use 'id' here plus 'narrowEventBackend'' if you need a more general mapping+  -- between selector types.+  (forall f'. s f' -> t f') ->+  -- | The causing event.+  Event m r t f ->+  EventBackend m r s+causedEventBackend inj Event {..} =+  narrowEventBackend inj $+    modifyEventBackend (setInitialCause $ referenceImpl impl) backend

@@ -18,6 +18,7 @@     unitEventBackend,     pairEventBackend,     hoistEventBackend,+    hoistEventImpl,     narrowEventBackend,     narrowEventBackend', @@ -89,7 +90,7 @@     addParentImpl :: !(r -> m ()),     addProximateImpl :: !(r -> m ()),     finalizeImpl :: !(m ()),-    failImpl :: !(Maybe SomeException -> m ())+    failImpl :: !(SomeException -> m ())   }  -- | A no-op 'EventBackend'.@@ -114,7 +115,7 @@       newOnceFlag = pure alwaysNewOnceFlag     } --- | An 'EventBackend' which sequentially generates 'Event's in the two given 'EventBackend's.+-- | 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).@@ -154,19 +155,21 @@   EventBackend n r s hoistEventBackend nt backend =   EventBackend-    { newEventImpl = nt . fmap hoistEventImpl . newEventImpl backend,+    { newEventImpl = nt . fmap (hoistEventImpl nt) . 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-        }++-- | 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 nt (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. --

@@ -1,61 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}---- |--- Description : "Dynamically typed" Event selectors and fields.--- Copyright   : Copyright 2022 Shea Levy.--- License     : Apache-2.0--- Maintainer  : shea@shealevy.com------ Instrumentors can use the types in this module if they don't want--- to define domain-specific types for the code they're instrumenting.-module Observe.Event.Dynamic-  ( DynamicEventSelector (..),-    DynamicField (..),--    -- * Shorthand types-    DynamicEventBackend,-    DynamicEvent,-  )-where--import Data.Aeson-import Data.String-import Data.Text-import Observe.Event---- | A simple type usable as an 'EventBackend' selector.------ All 'Event's have 'DynamicField' field types.------ Individual 'DynamicEventSelector's are typically constructed--- via the 'IsString' instance, e.g. @withEvent backend "foo" go@--- will call @go@ with an @Event m r DynamicEventSelector DynamicField@--- named "foo".-data DynamicEventSelector f where-  DynamicEventSelector :: !Text -> DynamicEventSelector DynamicField--instance (f ~ DynamicField) => IsString (DynamicEventSelector f) where-  fromString = DynamicEventSelector . fromString---- | A simple type usable as an 'Event' field type.------ Individual 'DynamicField's are typically constructed via--- the 'IsString' instance, using 'ToJSON' for the value,--- e.g. @addField ev $ "foo" x@ will add @DynamicField "foo" (toJSON x)@--- as a field to @ev@.-data DynamicField = DynamicField-  { name :: !Text,-    value :: !Value-  }---- | Treat a string as a function to a 'DynamicField', calling--- 'toJSON' on its argument.-instance (ToJSON x) => IsString (x -> DynamicField) where-  fromString s = DynamicField (fromString s) . toJSON---- | Shorthand for an 'EventBackend' using 'DynamicEventSelector's.-type DynamicEventBackend m r = EventBackend m r DynamicEventSelector---- | Shorthand for an 'Event' using 'DynamicField's.-type DynamicEvent m r = Event m r DynamicEventSelector DynamicField

@@ -1,140 +0,0 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}---- |--- Description : EventBackend for rendering events as JSON to a handle--- Copyright   : Copyright 2022 Shea Levy.--- License     : Apache-2.0--- Maintainer  : shea@shealevy.com-module Observe.Event.Render.IO.JSON-  ( jsonHandleBackend,-    simpleJsonStderrBackend,--    -- * Internals-    JSONRef (..),-  )-where--import Control.Concurrent.MVar-import Control.Exception-import Data.Aeson-import Data.Aeson.KeyMap (insert)-import Data.ByteString.Lazy.Char8 (hPutStrLn)-import Data.Coerce-import Data.IORef-import Data.Time.Clock-import Data.UUID (UUID)-import Data.UUID.V4-import Observe.Event-import Observe.Event.Backend-import Observe.Event.Render.JSON-import System.IO (Handle, stderr)---- | The reference type for 'EventBackend's generated by 'jsonHandleBackend'.------ Only expected to be used by type inference or by code implementing other backends--- using this one.-newtype JSONRef = JSONRef UUID deriving newtype (ToJSON)---- | An 'EventBackend' which posts events to a given 'Handle' as JSON.------ Each 'Event' is posted as a single line, as it's completed. As a result, child events--- will typically be posted __before__ their parents (though still possible to correlate via--- event IDs).------ The 'EventBackend' must be the exclusive writer to the 'Handle' while any events are live,--- but it does not 'System.IO.hClose' it itself.-jsonHandleBackend ::-  -- The type of structured exceptions-  (Exception stex) =>-  -- | Where to write 'Event's.-  Handle ->-  -- | Render a structured exception to JSON-  RenderExJSON stex ->-  -- | Render a selector, and the fields of 'Event's selected by it, to JSON-  RenderSelectorJSON s ->-  IO (EventBackend IO JSONRef s)-jsonHandleBackend h renderEx renderSel = do-  outputLock <- newMVar ()-  let emit :: Object -> IO ()-      emit o = withMVar outputLock \() ->-        hPutStrLn h $ encode o-  pure $-    EventBackend-      { newEventImpl = \sel -> do-          let (k, renderField) = renderSel sel-          eventRef <- coerce nextRandom-          start <- getCurrentTime-          fieldsRef <- newIORef mempty-          parentsRef <- newIORef mempty-          proximatesRef <- newIORef mempty-          let finish r = do-                end <- getCurrentTime-                fields <- readIORef fieldsRef-                parents <- readIORef parentsRef-                proximates <- readIORef proximatesRef-                emit-                  ( k-                      .= Object-                        ( "event-id" .= eventRef-                            <> "start" .= start-                            <> "end" .= end-                            <> ifNotNull "fields" fields-                            <> ifNotNull "parents" parents-                            <> ifNotNull "proximate-causes" proximates-                            <> case r of-                              Abort -> "abort" .= True-                              StructuredFail e -> "structured-exception" .= renderEx e-                              UnstructuredFail e -> "unstructured-exception" .= show e-                              Finalized -> mempty-                        )-                  )-          pure $-            EventImpl-              { referenceImpl = eventRef,-                addFieldImpl = \field ->-                  atomicModifyIORef' fieldsRef \fields ->-                    (uncurry insert (renderField field) fields, ()),-                addParentImpl = \r ->-                  atomicModifyIORef' parentsRef \refs -> (r : refs, ()),-                addProximateImpl = \r ->-                  atomicModifyIORef' proximatesRef \refs -> (r : refs, ()),-                finalizeImpl = finish Finalized,-                failImpl = \me ->-                  finish-                    ( case me of-                        Nothing -> Abort-                        Just e -> case fromException e of-                          Just se -> StructuredFail se-                          Nothing -> UnstructuredFail e-                    )-              },-        newOnceFlag = newOnceFlagMVar-      }---- | An 'EventBackend' which posts events to @stderr@ as JSON.------ Each 'Event' is posted as a single line, as it's completed. As a result, child events--- will typically be posted __before__ their parents (though still possible to correlate via--- event IDs).------ Any instrumented 'Exception's descended from 'SomeJSONException' will be structurally rendered.------ The 'EventBackend' must be the exclusive writer to @stderr@ while any events are live,--- but it does not 'System.IO.hClose' it itself.-simpleJsonStderrBackend :: RenderSelectorJSON s -> IO (EventBackend IO JSONRef s)-simpleJsonStderrBackend = jsonHandleBackend stderr renderJSONException---- | Why did an 'Event' finish?-data FinishReason stex-  = Abort-  | StructuredFail stex-  | UnstructuredFail SomeException-  | Finalized---- | Add k .= v if v is not 'null'.-ifNotNull :: (Foldable f, ToJSON (f v)) => Key -> f v -> Object-ifNotNull k v = if null v then mempty else k .= v

@@ -1,91 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}---- |--- Description : Renderers for serializing Events as JSON--- Copyright   : Copyright 2022 Shea Levy.--- License     : Apache-2.0--- Maintainer  : shea@shealevy.com------ Instrumentors will need to provide instances of 'RenderSelectorJSON'--- and 'RenderFieldJSON' for their domain-specific types to use their---  t'Observe.Event.Event's with JSON-consuming t'Observe.Event.EventBackend's.-module Observe.Event.Render.JSON-  ( RenderSelectorJSON,-    RenderFieldJSON,--    -- * Rendering structured exceptions-    RenderExJSON,--    -- ** SomeJSONException-    renderJSONException,-    SomeJSONException (..),-    jsonExceptionToException,-    jsonExceptionFromException,--    -- * Observe.Event.Dynamic support-    renderDynamicEventSelectorJSON,-    renderDynamicFieldJSON,-  )-where--import Control.Exception-import Data.Aeson-import Data.Aeson.Key-import Data.Typeable-import Observe.Event.Dynamic---- | A function to render a given selector, its fields, as JSON.------ The 'Key' is the event name/category.-type RenderSelectorJSON sel = forall f. sel f -> (Key, RenderFieldJSON f)---- | A function to render a given @field@ as JSON.------ The 'Key' is a field name, the 'Value' is an arbitrary--- rendering of the field value (if any).-type RenderFieldJSON field = field -> (Key, Value)---- | A function to render a given structured exception to JSON.-type RenderExJSON stex = stex -> Value---- | Render a 'DynamicEventSelector' and all its sub-fields.-renderDynamicEventSelectorJSON :: RenderSelectorJSON DynamicEventSelector-renderDynamicEventSelectorJSON (DynamicEventSelector n) =-  (fromText n, renderDynamicFieldJSON)---- | Render a 'DynamicField'-renderDynamicFieldJSON :: RenderFieldJSON DynamicField-renderDynamicFieldJSON f = (fromText (name f), value f)---- | Render a 'SomeJSONException' to JSON.------ It is __not__ necessary to use 'SomeJSONException' for the base of your--- structured exceptions in a JSON backend, so long as you provide a--- 'RenderExJSON' for your base exception type.-renderJSONException :: RenderExJSON SomeJSONException-renderJSONException (SomeJSONException render e) = render e---- | A possible base type for structured exceptions renderable to JSON.------ It is __not__ necessary to use 'SomeJSONException' for the base of your--- structured exceptions in a JSON backend, so long as you provide a--- 'RenderExJSON' for your base exception type.-data SomeJSONException-  = forall e. Exception e => SomeJSONException (RenderExJSON e) e--instance Show SomeJSONException where-  show (SomeJSONException _ e) = show e-  showsPrec i (SomeJSONException _ e) = showsPrec i e--instance Exception SomeJSONException---- | Used to create sub-classes of 'SomeJSONException'.-jsonExceptionToException :: (Exception e) => RenderExJSON e -> e -> SomeException-jsonExceptionToException render = toException . SomeJSONException render---- | Used to create sub-classes of 'SomeJSONException'.-jsonExceptionFromException :: (Exception e) => SomeException -> Maybe e-jsonExceptionFromException x = do-  SomeJSONException _ a <- fromException x-  cast a