diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for eventuo11y-json + +## 0.1.0.0 -- 2022-10-23 + +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/eventuo11y-json.cabal b/eventuo11y-json.cabal new file mode 100644 --- /dev/null +++ b/eventuo11y-json.cabal @@ -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 diff --git a/src/Observe/Event/Dynamic.hs b/src/Observe/Event/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Dynamic.hs @@ -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 diff --git a/src/Observe/Event/Render/JSON.hs b/src/Observe/Event/Render/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Render/JSON.hs @@ -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 diff --git a/src/Observe/Event/Render/JSON/DSL/Compile.hs b/src/Observe/Event/Render/JSON/DSL/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Render/JSON/DSL/Compile.hs @@ -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 + ) + ) diff --git a/src/Observe/Event/Render/JSON/Handle.hs b/src/Observe/Event/Render/JSON/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Render/JSON/Handle.hs @@ -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