{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Observe.Event.Render.JSON.Handle
( jsonHandleBackend,
simpleJsonStderrBackend,
JSONRef (..),
newJSONEvent,
)
where
import Control.Concurrent.MVar
import Control.Exception
import Data.Aeson
import Data.Aeson.KeyMap (fromList, 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)
newtype JSONRef = JSONRef UUID deriving newtype ([JSONRef] -> Encoding
[JSONRef] -> Value
JSONRef -> Encoding
JSONRef -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [JSONRef] -> Encoding
$ctoEncodingList :: [JSONRef] -> Encoding
toJSONList :: [JSONRef] -> Value
$ctoJSONList :: [JSONRef] -> Value
toEncoding :: JSONRef -> Encoding
$ctoEncoding :: JSONRef -> Encoding
toJSON :: JSONRef -> Value
$ctoJSON :: JSONRef -> Value
ToJSON)
newJSONEvent ::
(Exception stex) =>
(Object -> IO ()) ->
RenderExJSON stex ->
RenderFieldJSON f ->
Maybe JSONRef ->
[JSONRef] ->
[f] ->
IO (Event IO JSONRef f)
newJSONEvent :: forall stex f.
Exception stex =>
(Object -> IO ())
-> RenderExJSON stex
-> RenderFieldJSON f
-> Maybe JSONRef
-> [JSONRef]
-> [f]
-> IO (Event IO JSONRef f)
newJSONEvent Object -> IO ()
emit RenderExJSON stex
renderEx RenderFieldJSON f
renderField Maybe JSONRef
parent [JSONRef]
causes [f]
initialFields = do
JSONRef
eventRef <- coerce :: forall a b. Coercible a b => a -> b
coerce IO UUID
nextRandom
UTCTime
start <- IO UTCTime
getCurrentTime
IORef Object
fieldsRef <- forall a. a -> IO (IORef a)
newIORef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Key, v)] -> KeyMap v
fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RenderFieldJSON f
renderField [f]
initialFields
MVar ()
finishOnce <- forall a. IO (MVar a)
newEmptyMVar
let finish :: FinishReason stex -> IO ()
finish FinishReason stex
r =
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
finishOnce () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool
True -> do
UTCTime
end <- IO UTCTime
getCurrentTime
Object
fields <- forall a. IORef a -> IO a
readIORef IORef Object
fieldsRef
Object -> IO ()
emit
( Key
"event-id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= JSONRef
eventRef
forall a. Semigroup a => a -> a -> a
<> Key
"start" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime
start
forall a. Semigroup a => a -> a -> a
<> Key
"end" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime
end
forall a. Semigroup a => a -> a -> a
<> Key
"duration" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
end UTCTime
start
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) v.
(Foldable f, ToJSON (f v)) =>
Key -> f v -> Object
ifNotNull Key
"fields" Object
fields
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) v.
(Foldable f, ToJSON (f v)) =>
Key -> f v -> Object
ifNotNull Key
"parent" Maybe JSONRef
parent
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) v.
(Foldable f, ToJSON (f v)) =>
Key -> f v -> Object
ifNotNull Key
"proximate-causes" [JSONRef]
causes
forall a. Semigroup a => a -> a -> a
<> case FinishReason stex
r of
StructuredFail stex
e -> Key
"structured-exception" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RenderExJSON stex
renderEx stex
e
UnstructuredFail SomeException
e -> Key
"unstructured-exception" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. Show a => a -> String
show SomeException
e
FinishReason stex
Finalized -> forall a. Monoid a => a
mempty
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Event
{ reference :: JSONRef
reference = JSONRef
eventRef,
addField :: f -> IO ()
addField = \f
field ->
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Object
fieldsRef \Object
fields ->
(forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall v. Key -> v -> KeyMap v -> KeyMap v
insert (RenderFieldJSON f
renderField f
field) Object
fields, ()),
finalize :: Maybe SomeException -> IO ()
finalize = \Maybe SomeException
me -> FinishReason stex -> IO ()
finish forall a b. (a -> b) -> a -> b
$ case Maybe SomeException
me of
Just SomeException
e -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just stex
se -> forall stex. stex -> FinishReason stex
StructuredFail stex
se
Maybe stex
Nothing -> forall stex. SomeException -> FinishReason stex
UnstructuredFail SomeException
e
Maybe SomeException
Nothing -> forall stex. FinishReason stex
Finalized
}
jsonHandleBackend ::
(Exception stex) =>
Handle ->
RenderExJSON stex ->
RenderSelectorJSON s ->
IO (EventBackend IO JSONRef s)
jsonHandleBackend :: forall stex (s :: * -> *).
Exception stex =>
Handle
-> RenderExJSON stex
-> RenderSelectorJSON s
-> IO (EventBackend IO JSONRef s)
jsonHandleBackend Handle
h RenderExJSON stex
renderEx RenderSelectorJSON s
renderSel = do
MVar ()
outputLock <- forall a. a -> IO (MVar a)
newMVar ()
let emit :: Object -> IO ()
emit :: Object -> IO ()
emit Object
o = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
outputLock \() ->
Handle -> ByteString -> IO ()
hPutStrLn Handle
h forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode Object
o
eb :: EventBackend IO JSONRef s
eb =
EventBackend
{ newEvent :: forall f. NewEventArgs JSONRef s f -> IO (Event IO JSONRef f)
newEvent = \(NewEventArgs {s f
[f]
[JSONRef]
Maybe JSONRef
newEventSelector :: forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventParent :: forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventCauses :: forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventInitialFields :: forall r (s :: * -> *) f. NewEventArgs r s f -> [f]
newEventInitialFields :: [f]
newEventCauses :: [JSONRef]
newEventParent :: Maybe JSONRef
newEventSelector :: s f
..}) -> do
let (Key
k, RenderFieldJSON f
renderField) = RenderSelectorJSON s
renderSel s f
newEventSelector
forall stex f.
Exception stex =>
(Object -> IO ())
-> RenderExJSON stex
-> RenderFieldJSON f
-> Maybe JSONRef
-> [JSONRef]
-> [f]
-> IO (Event IO JSONRef f)
newJSONEvent (Object -> IO ()
emit forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=)) RenderExJSON stex
renderEx RenderFieldJSON f
renderField Maybe JSONRef
newEventParent [JSONRef]
newEventCauses [f]
newEventInitialFields,
emitImmediateEvent :: forall f. NewEventArgs JSONRef s f -> IO JSONRef
emitImmediateEvent = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) r f. Event m r f -> r
reference forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend IO JSONRef s
eb
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure EventBackend IO JSONRef s
eb
simpleJsonStderrBackend :: RenderSelectorJSON s -> IO (EventBackend IO JSONRef s)
simpleJsonStderrBackend :: forall (s :: * -> *).
RenderSelectorJSON s -> IO (EventBackend IO JSONRef s)
simpleJsonStderrBackend = forall stex (s :: * -> *).
Exception stex =>
Handle
-> RenderExJSON stex
-> RenderSelectorJSON s
-> IO (EventBackend IO JSONRef s)
jsonHandleBackend Handle
stderr (forall a. ToJSON a => a -> Value
toJSON @SomeJSONException)
data FinishReason stex
= StructuredFail stex
| UnstructuredFail SomeException
| Finalized
ifNotNull :: (Foldable f, ToJSON (f v)) => Key -> f v -> Object
ifNotNull :: forall (f :: * -> *) v.
(Foldable f, ToJSON (f v)) =>
Key -> f v -> Object
ifNotNull Key
k f v
v = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null f v
v then forall a. Monoid a => a
mempty else Key
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f v
v