{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 (..),
    newJSONEvent,
  )
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 ([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)

-- | Create a new 'Event' in a 'jsonHandleBackend'.
newJSONEvent ::
  (Exception stex) =>
  -- | Emit the final 'Object'. This will be called at most once.
  (Object -> IO ()) ->
  RenderExJSON stex ->
  RenderFieldJSON f ->
  IO (Event IO JSONRef f)
newJSONEvent :: forall stex f.
Exception stex =>
(Object -> IO ())
-> RenderExJSON stex
-> RenderFieldJSON f
-> IO (Event IO JSONRef f)
newJSONEvent Object -> IO ()
emit RenderExJSON stex
renderEx RenderFieldJSON f
renderField = 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 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
  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
            [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
"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
"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
                    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, ()),
        addReference :: Reference JSONRef -> IO ()
addReference = \(Reference ReferenceType
ty JSONRef
r) ->
          let refsRef :: IORef [JSONRef]
refsRef = case ReferenceType
ty of
                ReferenceType
Parent -> IORef [JSONRef]
parentsRef
                ReferenceType
Proximate -> IORef [JSONRef]
proximatesRef
           in forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [JSONRef]
refsRef \[JSONRef]
refs -> (JSONRef
r forall a. a -> [a] -> [a]
: [JSONRef]
refs, ()),
        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
      }

-- | 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
      { newEvent :: forall f. s f -> IO (Event IO JSONRef f)
newEvent = \s f
sel -> do
          let (Key
k, RenderFieldJSON f
renderField) = RenderSelectorJSON s
renderSel s f
sel
          forall stex f.
Exception stex =>
(Object -> IO ())
-> RenderExJSON stex
-> RenderFieldJSON 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
      }

-- | 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 (forall a. ToJSON a => a -> Value
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 :: 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