eventuo11y (empty) → 0.1.0.0
raw patch · 9 files changed
+1125/−0 lines, 9 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, exceptions, resourcet, text, time, unliftio-core, uuid
Files
- CHANGELOG.md +5/−0
- Example.hs +147/−0
- LICENSE +13/−0
- eventuo11y.cabal +71/−0
- src/Observe/Event.hs +462/−0
- src/Observe/Event/Dynamic.hs +61/−0
- src/Observe/Event/Implementation.hs +136/−0
- src/Observe/Event/Render/IO/JSON.hs +140/−0
- src/Observe/Event/Render/JSON.hs +90/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for eventuo11y++## 0.1.0.0 -- 2022-09-28++Initial release
+ Example.hs view
@@ -0,0 +1,147 @@+-- Search for comments to find commentary of interest+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Exception+import Control.Monad+import Data.Aeson+import Data.ByteString.Internal+import Data.Void+import Foreign.C.Error+import Foreign.C.Types+import Foreign.ForeignPtr.Safe+import Foreign.Ptr+import GHC.Generics+import Observe.Event+import Observe.Event.Render.IO.JSON+import Observe.Event.Render.JSON+import System.FilePath+import System.IO.Temp+import System.Posix.Files+import System.Posix.IO+import System.Posix.Types++-- Pretend this is in a separate module File where++-- 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 fptr sz) = do+ -- We start an event, selected by OpenFile+ fd <- withEvent backend OpenFile $ \ev -> do+ -- We add a Filename field to our current active event+ addField ev $ Filename path++ fd <- openFd path WriteOnly (Just regularFileMode) defaultFileFlags+ when (fd == -1) $ do+ errno <- getErrno+ -- Throw an exception which we can render as JSON+ throw $ BadOpen path errno++ addField ev $ FileFd fd+ pure fd+ withForeignPtr fptr $ \ptr -> do+ let bcSz = fromIntegral sz+ go :: ByteCount -> IO ()+ go offset = do+ newOffset <- withEvent backend WriteFile $ \ev -> do+ let ct = bcSz - offset+ addField ev $ BytesAsked ct+ written <- fdWriteBuf fd (plusPtr ptr (fromIntegral offset)) ct+ addField ev $ BytesActual written+ pure $ offset + written+ when (newOffset < bcSz) $+ go newOffset+ go 0+ 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,+ errno :: !Errno+ }+ deriving (Show, ToJSON, Generic)++-- Our exception is beneath SomeJSONException in the hierarchy+instance Exception BadOpen where+ toException = jsonExceptionToException+ fromException = jsonExceptionFromException++-- end module File++-- 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"++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
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2022 Shea Levy.++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this project except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ eventuo11y.cabal view
@@ -0,0 +1,71 @@+cabal-version: 3.0+name: eventuo11y+version: 0.1.0.0+synopsis: An event-oriented observability library+description:+ Instrument your Haskell codebase with wide, semantically meaningful events.+ This library is designed with separating the following concerns in mind:++ [@Writing instrumentation@] When instrumenting code, I want to think in terms of my+ application domain and report any information I might need to infer internal+ application-level state and understand the behavior of my program/library.++ [@Consuming instrumentation@] When consuming instrumentation, I want to think in+ terms of the API fo the specific backend I'm supporting (writing to @stderr@,+ serving a @Prometheus@ page, posting to @OpenTelemetry@) and what is needed to+ render to that API.++ [@Initializing instrumentation in an application@] When I'm ready to tie it all+ together, I want to identify the specific backends I want to post to and provide+ the bridge code to render the domain-specific instrumentation as needed for those+ backends. I also want to handle concerns like sampling or client-side aggregation+ of domain-specific instrumentation to keep usage manageable.++ See "Observe.Event" for detailed documentation on instrumenting your code.++ See "Observe.Event.Implementation" for documentation on writing an+ @EventBackend@.++ See [Example.hs](https://github.com/shlevy/eventuo11y/tree/v0.1.0.0/Example.hs) for an example.++ See [eventuo11y-batteries](https://hackage.haskell.org/package/eventuo11y-batteries) for miscellaneous+ framework-specific helpers.++bug-reports: https://github.com/shlevy/eventuo11y/issues+license: Apache-2.0+license-file: LICENSE+author: Shea Levy+maintainer: shea@shealevy.com+copyright: Copyright 2022 Shea Levy.+category: Observability+extra-source-files:+ CHANGELOG.md+ Example.hs++tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.2++source-repository head+ type: git+ location: https://github.com/shlevy/eventuo11y++library+ exposed-modules:+ Observe.Event+ Observe.Event.Dynamic+ Observe.Event.Implementation+ Observe.Event.Render.IO.JSON+ Observe.Event.Render.JSON++ build-depends:+ , aeson ^>=2.0.3.0+ , base >=4.14 && <4.17+ , bytestring >=0.10.12.0 && <0.12+ , exceptions ^>=0.10.4+ , resourcet ^>=1.2.4.3+ , text ^>=1.2.5.0+ , time >=1.9.3 && <1.12+ , unliftio-core ^>=0.2.0.1+ , uuid ^>=1.3.15++ hs-source-dirs: src+ default-language: Haskell2010
+ src/Observe/Event.hs view
@@ -0,0 +1,462 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Description : Core interface for instrumentation with eventuo11y+-- Copyright : Copyright 2022 Shea Levy.+-- License : Apache-2.0+-- Maintainer : shea@shealevy.com+--+-- This is the primary module needed to instrument code with eventuo11y.+--+-- Instrumentors should first define selector types and field types+-- appropriate to the unit of code they're instrumenting:+--+-- Selectors are values which designate the general category of event+-- being created, parameterized by 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).+--+-- 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 t'Observe.Event.Dynamic.DynamicField' for a generic option).+--+-- Instrumentation then centers around 'Event's, populated using the+-- <#g:eventmanip event manipulation functions>. 'Event's are initialized+-- with 'EventBackend's, typically via the+-- <#g:resourcesafe resource-safe event allocation functions>.+--+-- Depending on which 'EventBackend's may end up consuming the 'Event's,+-- instrumentors will also need to define renderers for their selectors+-- and fields. For example, they may need to implement values of types+-- t'Observe.Event.Render.JSON.RenderSelectorJSON' and+-- t'Observe.Event.Render.JSON.RenderFieldJSON' to use JSON rendering 'EventBackend's.+module Observe.Event+ ( Event,++ -- * Event manipulation #eventmanip#+ reference,+ addField,+ addParent,+ addProximate,++ -- * Resource-safe event allocation #resourcesafe#+ withEvent,+ withSubEvent,++ -- ** Acquire/MonadResource variants+ acquireEvent,+ acquireSubEvent,++ -- * 'EventBackend's+ EventBackend,+ subEventBackend,+ unitEventBackend,+ pairEventBackend,+ hoistEventBackend,+ narrowEventBackend,+ narrowEventBackend',++ -- * Primitive 'Event' resource management.++ -- | Prefer the [resource-safe event allocation functions](#g:resourcesafe)+ -- to these when possible.+ finalize,+ failEvent,+ newEvent,+ newSubEvent,+ )+where++import Control.Exception+import Control.Monad.Catch+import Control.Monad.IO.Unlift+import Data.Acquire+import Data.Functor+import Observe.Event.Implementation++-- | An instrumentation event.+--+-- 'Event's are the core of the instrumenting user's interface+-- to eventuo11y. Typical usage would be to create an 'Event'+-- from an 'EventBackend' with 'withEvent', or as a child of+-- an another 'Event' with 'withSubEvent', 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'.+-- [@s@]: The type of event selectors for child events. See 'EventBackend'.+-- [@f@]: The type of fields on this event. See 'addField'.+data Event m r s f = Event+ { -- | The 'EventBackend' this 'Event' was generated from.+ backend :: !(EventBackend m r s),+ -- | The underlying 'EventImpl' implementing the event functionality.+ impl :: !(EventImpl m r f),+ -- | A 'OnceFlag' to ensure we only finish ('finalize' or 'failEvent') once.+ finishFlag :: !(OnceFlag m)+ }++-- | Obtain a reference to an 'Event'.+--+-- References are used to link 'Event's together, either in+-- parent-child relationships with 'addParent' or in+-- cause-effect relationships with 'addProximate'.+--+-- References can live past when an event has been 'finalize'd or+-- 'failEvent'ed.+--+-- 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.+reference :: Event m r s f -> r+reference (Event {..}) = referenceImpl impl++-- | 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 t'Observe.Event.Dynamic.DynamicField'+-- for a generic option).+addField ::+ Event m r s f ->+ -- | The field to add to the event.+ f ->+ m ()+addField (Event {..}) = addFieldImpl impl++-- | Mark another 'Event' as a parent of this 'Event'.+addParent ::+ Event m r s f ->+ -- | A reference to the parent, obtained via 'reference'.+ r ->+ m ()+addParent (Event {..}) = addParentImpl impl++-- | Mark another 'Event' as a proximate cause of this 'Event'.+addProximate ::+ Event m r s f ->+ -- | A reference to the proximate cause, obtained via 'reference'.+ r ->+ m ()+addProximate (Event {..}) = addProximateImpl impl++-- | Mark an 'Event' as finished.+--+-- In normal usage, this should be automatically called via the use of+-- the [resource-safe event allocation functions](#g:resourcesafe).+--+-- This is a no-op if the 'Event' has already been 'finalize'd or+-- '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'.+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'.+--+-- In normal usage, this should be automatically called via the use of+-- the [resource-safe event allocation functions](#g:resourcesafe).+--+-- This is a no-op if the 'Event' has already been 'finalize'd or+-- '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 (Event {..}) = runOnce finishFlag . failImpl impl++-- | 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 t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).+--+-- Consider the [resource-safe event allocation functions](#g:resourcesafe) instead+-- of calling this directly.+newEvent ::+ (Applicative m) =>+ EventBackend m r s ->+ forall f.+ -- | The event selector.+ s f ->+ m (Event m r s f)+newEvent backend@(EventBackend {..}) sel = do+ impl <- newEventImpl sel+ finishFlag <- newOnceFlag+ pure Event {..}++-- | Create a new 'Event' as a child of the given '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 t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).+--+-- Consider the [resource-safe event allocation functions](#g:resourcesafe) instead+-- of calling this directly.+newSubEvent ::+ (Monad m) =>+ -- | The parent event.+ Event m r s f ->+ forall f'.+ -- | The child event selector.+ s f' ->+ m (Event m r s f')+newSubEvent (Event {..}) sel = do+ child <- newEvent backend sel+ addParent child $ referenceImpl impl+ pure child++-- | Run an action with 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 t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).+--+-- The 'Event' is automatically 'finalize'd (or, if appropriate, 'failEvent'ed)+-- at the end of the function it's passed to.+withEvent ::+ (MonadMask 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+ where+ release ev (ExitCaseSuccess _) = finalize ev+ release ev (ExitCaseException e) = failEvent ev $ Just e+ release ev ExitCaseAbort = failEvent ev Nothing++-- | Run an action with a new 'Event' as a child of the given '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 t'Observe.Event.Dynamic.DynamicEventSelector' for a generic option).+--+-- The 'Event' is automatically 'finalize'd (or, if appropriate, 'failEvent'ed)+-- at the end of the function it's passed to.+withSubEvent ::+ (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+withSubEvent (Event {..}) sel go = withEvent 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.+acquireEvent ::+ (MonadUnliftIO m) =>+ EventBackend m r s ->+ forall f.+ -- | The event selector.+ s f ->+ m (Acquire (Event m r s f))+acquireEvent backend sel = withRunInIO $ \runInIO ->+ pure $+ mkAcquireType+ (runInIO $ newEvent backend sel)+ (release runInIO)+ where+ release runInIO ev ReleaseException = runInIO $ failEvent ev Nothing+ 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.+acquireSubEvent ::+ (MonadUnliftIO m) =>+ -- | The parent event.+ Event m r s f ->+ forall f'.+ -- | The child event selector.+ s f' ->+ m (Acquire (Event m r s f'))+acquireSubEvent (Event {..}) sel = do+ childAcq <- acquireEvent backend sel+ withRunInIO $ \runInIO -> pure $ do+ child <- childAcq+ liftIO . runInIO . addParent child $ referenceImpl impl+ pure child++-- | An 'EventBackend' where every otherwise parentless event will be marked+-- as a child of the given 'Event'.+subEventBackend ::+ (Monad m) =>+ -- | 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+ }
+ src/Observe/Event/Dynamic.hs view
@@ -0,0 +1,61 @@+{-# 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
+ src/Observe/Event/Implementation.hs view
@@ -0,0 +1,136 @@+{-# 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)
+ src/Observe/Event/Render/IO/JSON.hs view
@@ -0,0 +1,140 @@+{-# 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.Implementation+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 = newOnceFlagIO+ }++-- | 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
+ src/Observe/Event/Render/JSON.hs view
@@ -0,0 +1,90 @@+{-# 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 e) = toJSON 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, ToJSON e) => SomeJSONException 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, ToJSON e) => e -> SomeException+jsonExceptionToException = toException . SomeJSONException++-- | Used to create sub-classes of 'SomeJSONException'.+jsonExceptionFromException :: (Exception e) => SomeException -> Maybe e+jsonExceptionFromException x = do+ SomeJSONException a <- fromException x+ cast a