{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Observe.Event.Render.IO.JSON
( jsonHandleBackend,
simpleJsonStderrBackend,
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)
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)
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
EventBackend
{ newEventImpl :: forall f. s f -> IO (EventImpl IO JSONRef f)
newEventImpl = \s f
sel -> do
let (Key
k, RenderFieldJSON f
renderField) = RenderSelectorJSON s
renderSel s f
sel
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 a. Monoid a => a
mempty
IORef [JSONRef]
parentsRef <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
IORef [JSONRef]
proximatesRef <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
let finish :: FinishReason stex -> IO ()
finish FinishReason stex
r = do
UTCTime
end <- IO UTCTime
getCurrentTime
Object
fields <- forall a. IORef a -> IO a
readIORef IORef Object
fieldsRef
[JSONRef]
parents <- forall a. IORef a -> IO a
readIORef IORef [JSONRef]
parentsRef
[JSONRef]
proximates <- forall a. IORef a -> IO a
readIORef IORef [JSONRef]
proximatesRef
Object -> IO ()
emit
( Key
k
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object -> Value
Object
( 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
<> 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
"parents" [JSONRef]
parents
forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) v.
(Foldable f, ToJSON (f v)) =>
Key -> f v -> Object
ifNotNull Key
"proximate-causes" [JSONRef]
proximates
forall a. Semigroup a => a -> a -> a
<> case FinishReason stex
r of
FinishReason stex
Abort -> Key
"abort" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
True
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
$
EventImpl
{ referenceImpl :: JSONRef
referenceImpl = JSONRef
eventRef,
addFieldImpl :: f -> IO ()
addFieldImpl = \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, ()),
addParentImpl :: JSONRef -> IO ()
addParentImpl = \JSONRef
r ->
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [JSONRef]
parentsRef \[JSONRef]
refs -> (JSONRef
r forall a. a -> [a] -> [a]
: [JSONRef]
refs, ()),
addProximateImpl :: JSONRef -> IO ()
addProximateImpl = \JSONRef
r ->
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [JSONRef]
proximatesRef \[JSONRef]
refs -> (JSONRef
r forall a. a -> [a] -> [a]
: [JSONRef]
refs, ()),
finalizeImpl :: IO ()
finalizeImpl = FinishReason stex -> IO ()
finish forall stex. FinishReason stex
Finalized,
failImpl :: Maybe SomeException -> IO ()
failImpl = \Maybe SomeException
me ->
FinishReason stex -> IO ()
finish
( case Maybe SomeException
me of
Maybe SomeException
Nothing -> forall stex. FinishReason stex
Abort
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
)
},
newOnceFlag :: IO (OnceFlag IO)
newOnceFlag = IO (OnceFlag IO)
newOnceFlagIO
}
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 RenderExJSON SomeJSONException
renderJSONException
data FinishReason stex
= Abort
| 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