eventuo11y-json (empty) → 0.1.0.0
raw patch · 7 files changed
+527/−0 lines, 7 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, eventuo11y, eventuo11y-dsl, template-haskell, text, th-compat, time, uuid
Files
- CHANGELOG.md +5/−0
- LICENSE +13/−0
- eventuo11y-json.cabal +54/−0
- src/Observe/Event/Dynamic.hs +61/−0
- src/Observe/Event/Render/JSON.hs +98/−0
- src/Observe/Event/Render/JSON/DSL/Compile.hs +159/−0
- src/Observe/Event/Render/JSON/Handle.hs +137/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for eventuo11y-json++## 0.1.0.0 -- 2022-10-23++Initial release
+ 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-json.cabal view
@@ -0,0 +1,54 @@+cabal-version: 3.0+name: eventuo11y-json+version: 0.1.0.0+synopsis: aeson-based rendering for eventuo11y+description:+ Render [eventuo11y](https://hackage.haskell.org/package/eventuo11y) 'Observe.Event.Event's+ to JSON.++ See "Observe.Event.Dynamic" for 'Observe.Event.Event' selectors that don't require+ generating domain-specific types and renderers.++ See "Observe.Event.Render.JSON" for renderer types.++ See "Observe.Event.Render.JSON.DSL.Compile" to compile the "Observe.Event.DSL" DSL+ in a way that generates "Observe.Event.Render.JSON" renderers.++ See "Observe.Event.Render.JSON.Handle" for rendering 'Observe.Event.Event's as+ JSON to a 'System.IO.Handle', and in particular to 'System.IO.stderr'.++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+tested-with: GHC == { 8.10.7, 9.2.4 }++source-repository head+ type: git+ location: https://github.com/shlevy/eventuo11y++library+ exposed-modules:+ Observe.Event.Dynamic+ Observe.Event.Render.JSON+ Observe.Event.Render.JSON.DSL.Compile+ Observe.Event.Render.JSON.Handle++ build-depends:+ , base ^>= { 4.14, 4.16 }+ , aeson ^>= 2.0+ , 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 }+ , uuid ^>= 1.3++ hs-source-dirs: src+ default-language: Haskell2010
+ src/Observe/Event/Dynamic.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- 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+import Observe.Event.Syntax++-- | 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 'RecordField' 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+ }++instance (ToJSON a) => RecordField Text a DynamicField where+ k ≔ v = DynamicField k $ toJSON v++-- | 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/Render/JSON.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Description : Renderers for serializing Events as JSON+-- Copyright : Copyright 2022 Shea Levy.+-- License : Apache-2.0+-- Maintainer : shea@shealevy.com+--+-- Rendering types for JSON-consuming 'Observe.Event.EventBackend's.+--+-- Instances of 'RenderSelectorJSON' and 'RenderFieldJSON' can be generated+-- by "Observe.Event.Render.JSON.DSL.Compile".+module Observe.Event.Render.JSON+ ( RenderSelectorJSON,+ RenderFieldJSON,++ -- * Default renderers+ DefaultRenderSelectorJSON (..),+ DefaultRenderFieldJSON (..),++ -- * Rendering structured exceptions+ RenderExJSON,++ -- ** SomeJSONException+ SomeJSONException (..),+ jsonExceptionToException,+ jsonExceptionFromException,+ )+where++import Control.Exception+import Data.Aeson+import Data.Aeson.Key+import Data.Typeable+import Data.Void+import Observe.Event.Dynamic++-- | A function to render a given selector, and 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 default 'RenderSelectorJSON', useful for auto-generation and simple+-- backend invocation.+class DefaultRenderSelectorJSON sel where+ defaultRenderSelectorJSON :: RenderSelectorJSON sel++-- | A default 'RenderFieldJSON', useful for auto-generation and simple+-- backend invocation.+class DefaultRenderFieldJSON field where+ defaultRenderFieldJSON :: RenderFieldJSON field++instance DefaultRenderFieldJSON Void where+ defaultRenderFieldJSON = absurd++instance DefaultRenderSelectorJSON DynamicEventSelector where+ defaultRenderSelectorJSON (DynamicEventSelector n) =+ (fromText n, defaultRenderFieldJSON)++instance DefaultRenderFieldJSON DynamicField where+ defaultRenderFieldJSON (DynamicField {..}) = (fromText name, value)++-- | A function to render a given structured exception to JSON.+type RenderExJSON stex = stex -> Value++-- | 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 (or use 'ToJSON'-based rendering).+data SomeJSONException = forall e. (Exception e, ToJSON e) => SomeJSONException e++instance Show SomeJSONException where+ showsPrec i (SomeJSONException e) = showsPrec i e++instance ToJSON SomeJSONException where+ toJSON (SomeJSONException e) = toJSON e+ toEncoding (SomeJSONException e) = toEncoding 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
+ src/Observe/Event/Render/JSON/DSL/Compile.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++-- |+-- Description : Compile the "Observe.Event.DSL" and generate "Observe.Event.Render.JSON" instances+-- Copyright : Copyright 2022 Shea Levy.+-- License : Apache-2.0+-- Maintainer : shea@shealevy.com+module Observe.Event.Render.JSON.DSL.Compile (compile) where++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++conPCompat :: Name -> [Pat] -> Pat+#if MIN_VERSION_template_haskell(2,18,0)+conPCompat n ps = ConP n [] ps+#else+conPCompat = ConP+#endif++-- | Compile a 'SelectorSpec' to type definitions, with a 'DefaultRenderSelectorJSON' instance.+--+-- 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 s@(SelectorSpec selectorNameBase selectors) = do+ -- Walks the selectors twice, will fix when SelectorSpec is extensible (e.g. recursion-schemes)+ baseDecs <- DSL.compile s+ let (renderSelectorClauses, decs) = foldr stepSelectors (mempty, baseDecs) selectors+ selectorInstance =+ InstanceD+ Nothing+ []+ (AppT (ConT ''DefaultRenderSelectorJSON) (ConT selectorName))+ [FunD 'defaultRenderSelectorJSON renderSelectorClauses]+ pure $ selectorInstance : decs+ where+ -- Deduplicate this with e11y-dsl when extending language+ selectorName = mkName $ upperCamel selectorNameBase <> "Selector"++ stepSelectors (SelectorConstructorSpec nm NoFields) (renderSelectorClauses, decs) = (c : renderSelectorClauses, decs)+ where+ c =+ Clause+ [conPCompat (mkName $ upperCamel nm) []]+ ( NormalB+ ( TupE+ [ Just . LitE $ StringL (kebab nm),+ Just $ VarE 'defaultRenderFieldJSON+ ]+ )+ )+ []+ stepSelectors (SelectorConstructorSpec nm (Inject _)) (renderSelectorClauses, decs) = (c : renderSelectorClauses, decs)+ where+ keyNm = mkName "key"+ renderNm = mkName "render"+ selNm = mkName "sel"+ c =+ Clause+ [conPCompat (mkName $ upperCamel nm) [VarP selNm]]+ ( NormalB+ ( TupE+ [ Just $ InfixE (Just . LitE $ StringL (kebab nm <> ":")) (VarE '(<>)) (Just $ VarE keyNm),+ Just $ VarE renderNm+ ]+ )+ )+ [ ValD (TupP [VarP keyNm, VarP renderNm]) (NormalB $ AppE (VarE 'defaultRenderSelectorJSON) (VarE selNm)) []+ ]+ -- TODO handle case where field is not ToJSON+ stepSelectors (SelectorConstructorSpec nm (SimpleType _)) (renderSelectorClauses, decs) = (c : renderSelectorClauses, decs)+ where+ xNm = mkName "x"+ c =+ Clause+ [conPCompat (mkName $ upperCamel nm) []]+ ( NormalB+ ( TupE+ [ Just . LitE $ StringL (kebab nm),+ Just+ . LamE+ [ VarP xNm+ ]+ $ TupE+ [ Just . LitE $ StringL "val", -- Extend SimpleType with field name+ Just $ AppE (VarE 'toJSON) (VarE xNm)+ ]+ ]+ )+ )+ []+ stepSelectors (SelectorConstructorSpec nm (Specified fieldSpec)) (renderSelectorClauses, decs) = (c : renderSelectorClauses, fieldDec : decs)+ where+ c =+ Clause+ [conPCompat (mkName $ upperCamel nm) []]+ ( NormalB+ ( TupE+ [ Just . LitE $ StringL (kebab nm),+ Just $ VarE 'defaultRenderFieldJSON+ ]+ )+ )+ []+ fieldDec = compileFieldSpec fieldSpec++compileFieldSpec :: FieldSpec -> Dec+compileFieldSpec (FieldSpec fieldNameBase fields) =+ InstanceD+ Nothing+ []+ (AppT (ConT ''DefaultRenderFieldJSON) (ConT fieldName))+ [FunD 'defaultRenderFieldJSON (renderFieldClause <$> fields)]+ where+ -- Deduplicate this with e11y-dsl when extending language+ fieldName = mkName $ upperCamel fieldNameBase <> "Field"+ renderFieldClause (FieldConstructorSpec ctorNm ts) =+ Clause+ [conPCompat (mkName $ upperCamel ctorNm) (map VarP argNms)]+ ( NormalB+ ( TupE+ [ Just . LitE $ StringL (kebab ctorNm),+ Just $ valE+ ]+ )+ )+ []+ where+ len = length ts+ argNms = fmap (\idx -> mkName $ "x" <> show idx) [1 .. len]+ valE = case argNms of+ [] -> ConE 'Null+ [argNm] -> AppE (VarE 'toJSON) (VarE argNm)+ _ ->+ AppE+ (ConE 'Object)+ ( AppE+ (VarE 'fromList)+ ( ListE . fst $+ foldr+ ( \argNm (jsonEs, idx) ->+ ( TupE+ [ Just . LitE $ StringL (show idx),+ Just $ AppE (VarE 'toJSON) (VarE argNm)+ ] :+ jsonEs,+ idx - 1+ )+ )+ ([], len)+ argNms+ )+ )
+ src/Observe/Event/Render/JSON/Handle.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- 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.JSON.Handle+ ( 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+ 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+ }++-- | 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 (toJSON @SomeJSONException)++-- | Why did an 'Event' finish?+data FinishReason stex+ = 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