diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for eventuo11y-json +## 0.2.0.0 -- 2022-12-23 + +- Update for eventuo11y 0.6 +- Update for 'AnyQuote' change in 'eventuo11y-dsl' version '0.2' +- Export duration on rendered events + ## 0.1.0.0 -- 2022-10-23 Initial release diff --git a/eventuo11y-json.cabal b/eventuo11y-json.cabal --- a/eventuo11y-json.cabal +++ b/eventuo11y-json.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: eventuo11y-json -version: 0.1.0.0 +version: 0.2.0.0 synopsis: aeson-based rendering for eventuo11y description: Render [eventuo11y](https://hackage.haskell.org/package/eventuo11y) 'Observe.Event.Event's @@ -39,15 +39,14 @@ Observe.Event.Render.JSON.Handle build-depends: - , base ^>= { 4.14, 4.16 } - , aeson ^>= 2.0 + , base ^>= { 4.14, 4.16, 4.17 } + , aeson ^>= { 2.0, 2.1 } , bytestring ^>= { 0.10, 0.11 } - , eventuo11y ^>= 0.5.0.0 - , eventuo11y-dsl ^>= 0.1.0.0 - , template-haskell ^>= { 2.16, 2.18 } - , text ^>= 1.2 - , th-compat ^>= 0.1.4 - , time ^>= { 1.9, 1.11 } + , eventuo11y ^>= 0.6 + , eventuo11y-dsl ^>= 0.2 + , template-haskell ^>= { 2.16, 2.18, 2.19 } + , text ^>= { 1.2, 2.0 } + , time ^>= { 1.9, 1.11, 1.12 } , uuid ^>= 1.3 hs-source-dirs: src diff --git a/src/Observe/Event/Dynamic.hs b/src/Observe/Event/Dynamic.hs --- a/src/Observe/Event/Dynamic.hs +++ b/src/Observe/Event/Dynamic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} -- | -- Description : "Dynamically typed" Event selectors and fields. @@ -58,4 +59,4 @@ type DynamicEventBackend m r = EventBackend m r DynamicEventSelector -- | Shorthand for an 'Event' using 'DynamicField's. -type DynamicEvent m r = Event m r DynamicEventSelector DynamicField +type DynamicEvent m r = Event m r DynamicField diff --git a/src/Observe/Event/Render/JSON/DSL/Compile.hs b/src/Observe/Event/Render/JSON/DSL/Compile.hs --- a/src/Observe/Event/Render/JSON/DSL/Compile.hs +++ b/src/Observe/Event/Render/JSON/DSL/Compile.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskellQuotes #-} +#if ! MIN_VERSION_template_haskell(2,18,0) +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +#endif -- | -- Description : Compile the "Observe.Event.DSL" and generate "Observe.Event.Render.JSON" instances @@ -11,11 +15,14 @@ import Data.Aeson import GHC.Exts import Language.Haskell.TH -import Language.Haskell.TH.Syntax.Compat as THC import Observe.Event.DSL import qualified Observe.Event.DSL.Compile as DSL import Observe.Event.Render.JSON +#if ! MIN_VERSION_template_haskell(2,18,0) +type Quote m = m ~ Q +#endif + conPCompat :: Name -> [Pat] -> Pat #if MIN_VERSION_template_haskell(2,18,0) conPCompat n ps = ConP n [] ps @@ -27,7 +34,7 @@ -- -- Assumes leaf types (i.e., those in 'SimpleType' or a 'FieldConstructorSpec') are 'ToJSON', and -- that 'Inject'ed selectors have a 'DefaultRenderSelectorJSON' instance. -compile :: (THC.Quote m) => SelectorSpec -> m [Dec] +compile :: (Quote m) => SelectorSpec -> m [Dec] compile s@(SelectorSpec selectorNameBase selectors) = do -- Walks the selectors twice, will fix when SelectorSpec is extensible (e.g. recursion-schemes) baseDecs <- DSL.compile s diff --git a/src/Observe/Event/Render/JSON/Handle.hs b/src/Observe/Event/Render/JSON/Handle.hs --- a/src/Observe/Event/Render/JSON/Handle.hs +++ b/src/Observe/Event/Render/JSON/Handle.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} @@ -16,6 +17,7 @@ -- * Internals JSONRef (..), + newJSONEvent, ) where @@ -40,6 +42,60 @@ -- using this one. newtype JSONRef = JSONRef UUID deriving newtype (ToJSON) +-- | Create a new 'Event' in a 'jsonHandleBackend'. +newJSONEvent :: + (Exception stex) => + -- | Emit the final 'Object'. This will be called at most once. + (Object -> IO ()) -> + RenderExJSON stex -> + RenderFieldJSON f -> + IO (Event IO JSONRef f) +newJSONEvent emit renderEx renderField = do + eventRef <- coerce nextRandom + start <- getCurrentTime + fieldsRef <- newIORef mempty + parentsRef <- newIORef mempty + proximatesRef <- newIORef mempty + finishOnce <- newEmptyMVar + let finish r = + tryPutMVar finishOnce () >>= \case + False -> pure () + True -> do + end <- getCurrentTime + fields <- readIORef fieldsRef + parents <- readIORef parentsRef + proximates <- readIORef proximatesRef + emit + ( "event-id" .= eventRef + <> "start" .= start + <> "end" .= end + <> "duration" .= diffUTCTime end start + <> ifNotNull "fields" fields + <> ifNotNull "parents" parents + <> ifNotNull "proximate-causes" proximates + <> case r of + StructuredFail e -> "structured-exception" .= renderEx e + UnstructuredFail e -> "unstructured-exception" .= show e + Finalized -> mempty + ) + pure $ + Event + { reference = eventRef, + addField = \field -> + atomicModifyIORef' fieldsRef \fields -> + (uncurry insert (renderField field) fields, ()), + addReference = \(Reference ty r) -> + let refsRef = case ty of + Parent -> parentsRef + Proximate -> proximatesRef + in atomicModifyIORef' refsRef \refs -> (r : refs, ()), + finalize = \me -> finish $ case me of + Just e -> case fromException e of + Just se -> StructuredFail se + Nothing -> UnstructuredFail e + Nothing -> Finalized + } + -- | 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 @@ -65,52 +121,9 @@ hPutStrLn h $ encode o pure $ EventBackend - { newEventImpl = \sel -> do + { newEvent = \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 - 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 = \e -> - finish - ( case fromException e of - Just se -> StructuredFail se - Nothing -> UnstructuredFail e - ) - }, - newOnceFlag = newOnceFlagMVar + newJSONEvent (emit . (k .=)) renderEx renderField } -- | An 'EventBackend' which posts events to @stderr@ as JSON.