{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- |
-- 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.IO.JSON
  ( 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.Implementation
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 ([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)

-- | 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 :: 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
      }

-- | 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 :: 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

-- | Why did an 'Event' finish?
data FinishReason stex
  = Abort
  | StructuredFail stex
  | UnstructuredFail SomeException
  | Finalized

-- | Add k .= v if v is not 'null'.
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